From 05e930a0a53da5c994eadc170a4740c9a632c09c Mon Sep 17 00:00:00 2001 From: rnhmjoj Date: Sun, 2 Jan 2022 01:31:35 +0100 Subject: [PATCH] add option to bypass locks --- Main.hs | 131 +++++++++++++++++++++++++++++++++++++++++------------ man/bisc.1 | 5 ++ 2 files changed, 108 insertions(+), 28 deletions(-) diff --git a/Main.hs b/Main.hs index 51838e8..36dedd9 100644 --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} -- Databases import Database.Selda (Text, liftIO, (!)) @@ -32,8 +33,11 @@ import qualified Data.ByteString as B import qualified Paths_bisc as Bisc import Data.Version (showVersion) +-- File locking bypass +import qualified System.Posix.Files as Posix + -- Misc -import Data.List (nub) +import Data.List (nub, isInfixOf) import Data.Maybe (mapMaybe) import Data.Function ((&)) import Data.Default (def) @@ -56,6 +60,7 @@ data Settings = Settings data Options = Options { version :: Bool -- ^ print version number , dryRun :: Bool -- ^ don't delete anything + , unsafe :: Bool -- ^ ignore locks , configPath :: FilePath -- ^ config file path } @@ -75,6 +80,13 @@ cliParser defConfig = O.info (O.helper <*> parser) infos <> O.help ("Don't actually remove anything, "<> "just show what would be done") ) + <*> O.switch + ( O.long "unsafe" + <> O.short 'u' + <> O.help ("Ignore database locks. " <> + "This will probably corrupt the databases, but " <> + "works while the browser is running.") + ) <*> O.strOption ( O.long "config" <> O.short 'c' @@ -182,23 +194,32 @@ actions = , ("SessionStorage", deleteSessionStorage) ] + -- | Deletes records in the Cookies database deleteCookies :: Action Result deleteCookies = do - database <- ( "Cookies") <$> asks webenginePath + 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 when (not exists) (throwError "database is missing") whitelist <- map S.text <$> asks whitelist - CE.handle dbErrors $ withSQLite database $ do - bad <- S.query $ do - cookie <- S.select cookies - S.restrict (by whitelist cookie) - return (cookie ! #host_key) - when (not dry) $ - S.deleteFrom_ cookies (by whitelist) - return (length bad, nub bad) + context $ \database -> do + CE.handle dbErrors $ withSQLite database $ do + bad <- S.query $ do + cookie <- S.select cookies + S.restrict (by whitelist cookie) + return (cookie ! #host_key) + when (not dry) $ + S.deleteFrom_ cookies (by whitelist) + return (length bad, nub bad) where by set x = S.not_ (x ! #host_key `S.isIn` set) @@ -206,20 +227,28 @@ deleteCookies = do -- | Deletes records in the QuotaManager API database deleteQuotaOrigins :: Action Result deleteQuotaOrigins = do - database <- ( "QuotaManager") <$> asks webenginePath + 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 when (not exists) (throwError "database is missing") whitelist <- map pattern <$> asks whitelist - CE.handle dbErrors $ withSQLite database $ do - bad <- S.query $ do - quota <- S.select quotaOrigins - S.restrict (by whitelist quota) - return (quota ! #origin) - when (not dry) $ - S.deleteFrom_ quotaOrigins (by whitelist) - return (length bad, nub bad) + context $ \database -> do + CE.handle dbErrors $ withSQLite database $ do + bad <- S.query $ do + quota <- S.select quotaOrigins + S.restrict (by whitelist quota) + return (quota ! #origin) + when (not dry) $ + S.deleteFrom_ quotaOrigins (by whitelist) + return (length bad, nub bad) where -- check if quota is not whitelisted by whitelist quota = S.not_ (S.true `S.isIn` matches) @@ -233,7 +262,6 @@ deleteQuotaOrigins = do pattern domain = "http%://%" <> domain <> "/" - -- | Deletes per-domain files under the IndexedDB directory -- -- For example: @@ -249,7 +277,7 @@ deleteIndexedDB = do when (not exists) $ throwError "directory is missing" entries <- listDirectoryAbs (webengine "IndexedDB") - unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist + unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist let badFiles = filterMaybe (fmap unlisted . domain) entries badDomains = mapMaybe domain badFiles @@ -290,13 +318,21 @@ deleteLocalStorage = do whitelist <- asks whitelist let path = webengine "Local Storage" "leveldb" + dry <- asks (dryRun . options) + unsafe <- asks (unsafe . options) + + when (not dry && unsafe) $ liftIO $ do + -- delete and recreate the lock file to bypass POSIX locks + D.removeFile (path "LOCK") + T.writeFile (path "LOCK") "" + dbIsOk <- liftIO $ D.doesFileExist (path "LOCK") when (not dbIsOk) (throwError "database is missing or corrupted") version <- withRetryDB path (\db -> L.get db def "VERSION") when (version /= Just "1") (throwError "database is empty or the schema unsupported") - dry <- asks (dryRun . options) + -- when dry running replace the delete function with a nop let delete = if dry then (\_ _ _ -> pure ()) else L.delete withDB path $ \db -> do @@ -338,13 +374,21 @@ deleteSessionStorage = do whitelist <- asks whitelist let path = webengine "Session Storage" + dry <- asks (dryRun . options) + unsafe <- asks (unsafe . options) + + when (not dry && unsafe) $ liftIO $ do + -- delete and recreate the lock file to bypass POSIX locks + D.removeFile (path "LOCK") + T.writeFile (path "LOCK") "" + dbIsOk <- liftIO $ D.doesFileExist (path "LOCK") when (not dbIsOk) (throwError "database is missing or corrupted") version <- withRetryDB path (\db -> L.get db def "version") when (version /= Just "1") (throwError "database is empty or the schema unsupported") - dry <- asks (dryRun . options) + -- when dry running replace the delete function with a nop let delete = if dry then (\_ _ _ -> pure ()) else L.delete withDB path $ \db -> do @@ -389,6 +433,7 @@ deleteSessionStorage = do -- 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 @@ -397,11 +442,36 @@ withRetryDB path action = do case res of Right b -> return b Left (e :: BE.IOException) -> - if not ("Corruption" `T.isInfixOf` msg) - then throwError ("error opening the database:\n " <> msg) - else liftIO $ L.repair path def >> withDB path action + if | "Corruption" `T.isInfixOf` msg -> do + -- try repairing before giving up + liftIO $ L.repair path def + withDB path action + | "unavailable" `T.isInfixOf` msg -> + throwError "database is locked (in use by another process)" + | otherwise -> + throwError ("error opening the database:\n " <> msg) where msg = T.pack (BE.displayException e) + +-- | Bypass SQLite locking mechanism +-- +-- 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 + dir <- asks webenginePath + let + real = dir dbName + link = real <> "-bypass" + -- bypass the SQLite POSIX locks with hard links + liftIO (Posix.createLink real link) + res <- cont database + -- remove the hard links + liftIO (Posix.removeLink link) + return res + + -- | Loads the config file/cli options loadSettings :: Options -> IO Settings loadSettings opts = do @@ -418,7 +488,12 @@ loadSettings opts = do return (Settings webengine domains opts) + -- | Catches any Selda error dbErrors :: S.SeldaError -> Action a -dbErrors e = throwError $ - "database operation failed: " <> T.pack (BE.displayException e) +dbErrors (S.DbError msg) = throwError $ "error opening database: " <> T.pack msg +dbErrors e = + if "ErrorBusy" `isInfixOf` msg + then throwError "database is locked (in use by another process)" + else throwError $ "database operation failed: " <> T.pack msg + where msg = BE.displayException e diff --git a/man/bisc.1 b/man/bisc.1 index ad775bb..b7be8d9 100644 --- a/man/bisc.1 +++ b/man/bisc.1 @@ -43,6 +43,11 @@ Use FILE as the configuration file. .BR -n ","\ --dry-run Don't actually remove anything, just show what would be done. .TP +.BR -u ","\ --unsafe +Ignore database locks. +This will probably corrupt the databases, but works while the browser is +running. +.TP .BR -h ","\ --help Show the program information and help screen.