diff --git a/Main.hs b/Main.hs index 36dedd9..cd40ecb 100644 --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/bisc.cabal b/bisc.cabal index 2a1b0e9..a105ac5 100644 --- a/bisc.cabal +++ b/bisc.cabal @@ -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++