fix some warnings

master
Michele Guerini Rocco 2022-01-02 02:34:27 +01:00
parent 05e930a0a5
commit 6f371de3aa
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450
2 changed files with 24 additions and 32 deletions

50
Main.hs
View File

@ -7,8 +7,9 @@
{-# LANGUAGE MultiWayIf #-}
-- Databases
import Database.Selda (Text, liftIO, (!))
import Database.Selda.SQLite (withSQLite)
import Database.Selda (Text, liftIO, (!))
import Database.Selda.SQLite (withSQLite)
import Control.Monad.Trans.Resource (ResourceT)
import qualified Database.Selda as S
import qualified Database.LevelDB as L
import qualified Database.LevelDB.Streaming as LS
@ -200,18 +201,13 @@ deleteCookies :: Action Result
deleteCookies = do
dir <- asks webenginePath
dry <- asks (dryRun . options)
unsafe <- asks (unsafe . options)
let
database = dir </> "Cookies"
context = if unsafe then bypassLocks "Cookies"
else ($ database)
exists <- liftIO $ D.doesFileExist database
-- check for database
exists <- liftIO $ D.doesFileExist (dir </> "Cookies")
when (not exists) (throwError "database is missing")
whitelist <- map S.text <$> asks whitelist
context $ \database -> do
withoutLocks "Cookies" $ \database -> do
CE.handle dbErrors $ withSQLite database $ do
bad <- S.query $ do
cookie <- S.select cookies
@ -229,18 +225,13 @@ deleteQuotaOrigins :: Action Result
deleteQuotaOrigins = do
dir <- asks webenginePath
dry <- asks (dryRun . options)
unsafe <- asks (unsafe . options)
let
database = dir </> "QuotaManager"
context = if unsafe then bypassLocks "QuotaManager"
else ($ database)
exists <- liftIO $ D.doesFileExist database
-- check for database
exists <- liftIO $ D.doesFileExist (dir </> "QuotaManager")
when (not exists) (throwError "database is missing")
whitelist <- map pattern <$> asks whitelist
context $ \database -> do
whitelist <- map mkPattern <$> asks whitelist
withoutLocks "QuotaManager" $ \database -> do
CE.handle dbErrors $ withSQLite database $ do
bad <- S.query $ do
quota <- S.select quotaOrigins
@ -259,7 +250,7 @@ deleteQuotaOrigins = do
S.restrict (url `S.like` S.the pattern)
return S.true
-- turns domains into patterns to match a url
pattern domain = "http%://%" <> domain <> "/"
mkPattern domain = "http%://%" <> domain <> "/"
-- | Deletes per-domain files under the IndexedDB directory
@ -429,14 +420,12 @@ deleteSessionStorage = do
-- * Helper functions
-- | Loads a leveldb database and runs a resourceT action
--
-- withDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withDB path f = liftIO $ L.runResourceT (L.open path def >>= f)
-- | Like 'withDB' but retry the action after repairing the db
--
-- withRetryDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withRetryDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withRetryDB path action = do
res <- CE.try (withDB path action)
case res of
@ -458,17 +447,20 @@ withRetryDB path action = do
-- SQLite manages concurrent access via POSIX locks: these are tied to a
-- specific file and pid. They can be bypassed by simply creating a hard
-- link (pointing to the same inode), editing the link and then removing it.
bypassLocks :: String -> (FilePath -> Action a) -> Action a
bypassLocks dbName cont = do
withoutLocks :: String -> (FilePath -> Action a) -> Action a
withoutLocks dbName cont = do
dir <- asks webenginePath
unsafe <- asks (unsafe . options)
let
real = dir </> dbName
link = real <> "-bypass"
-- bypass the SQLite POSIX locks with hard links
liftIO (Posix.createLink real link)
res <- cont database
when unsafe $ liftIO (Posix.createLink real link)
res <- cont (if unsafe then link else real)
-- remove the hard links
liftIO (Posix.removeLink link)
when unsafe $ liftIO (Posix.removeLink link)
return res

View File

@ -37,12 +37,12 @@ executable bisc
main-is: Main.hs
build-depends: base ==4.* , selda ==0.*,
selda-sqlite ==0.*,
leveldb-haskell ==0.*,
filepath, directory, text,
leveldb-haskell ==0.*, resourcet,
filepath, directory, text, unix,
mtl, configurator, exceptions,
data-default, bytestring,
optparse-applicative
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -Wall -Wno-name-shadowing
if flag(static)
extra-libraries: snappy stdc++