diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -4,10 +4,12 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# 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 @@ -32,8 +34,11 @@ 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 +61,7 @@ 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 +81,13 @@ <> 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 +195,27 @@ , ("SessionStorage", deleteSessionStorage) ] + -- | Deletes records in the Cookies database deleteCookies :: Action Result deleteCookies = do - database <- ( "Cookies") <$> asks webenginePath + dir <- asks webenginePath dry <- asks (dryRun . options) - 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 - 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) + withoutLocks "Cookies" $ \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 +223,23 @@ -- | Deletes records in the QuotaManager API database deleteQuotaOrigins :: Action Result deleteQuotaOrigins = do - database <- ( "QuotaManager") <$> asks webenginePath + dir <- asks webenginePath dry <- asks (dryRun . options) - 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 - 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) + whitelist <- map mkPattern <$> asks whitelist + withoutLocks "QuotaManager" $ \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) @@ -230,8 +250,7 @@ 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 @@ -249,7 +268,7 @@ 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 +309,21 @@ 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 +365,21 @@ 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 @@ -385,23 +420,50 @@ -- * 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 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. +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 + when unsafe $ liftIO (Posix.createLink real link) + + res <- cont (if unsafe then link else real) + + -- remove the hard links + when unsafe $ liftIO (Posix.removeLink link) + return res + + -- | Loads the config file/cli options loadSettings :: Options -> IO Settings loadSettings opts = do @@ -418,7 +480,12 @@ 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -66,7 +66,7 @@ ## License -Copyright (C) 2021 Michele Guerini Rocco +Copyright (C) 2022 Michele Guerini Rocco This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/bisc.cabal b/bisc.cabal --- a/bisc.cabal +++ b/bisc.cabal @@ -1,5 +1,5 @@ name: bisc -version: 0.4.0.0 +version: 0.4.1.0 synopsis: A small tool that clears cookies (and more). description: @@ -19,7 +19,7 @@ license-file: LICENSE author: Michele Guerini Rocco maintainer: rnhmjoj@inventati.org -copyright: Copyright (C) 2021 Michele Guerini Rocco +copyright: Copyright (C) 2022 Michele Guerini Rocco category: Utility build-type: Simple extra-source-files: README.md, man/bisc.1 man/bisc.conf.5 @@ -37,12 +37,12 @@ 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 -O2 if flag(static) extra-libraries: snappy stdc++ diff --git a/man/bisc.1 b/man/bisc.1 --- a/man/bisc.1 +++ b/man/bisc.1 @@ -1,4 +1,4 @@ -.TH bisc 1 "Semptember 7, 2021" "bisc 0.4.0" "User Commands" +.TH bisc 1 "January 11, 2022" "bisc 0.4.1" "User Commands" .SH NAME bisc - a small tool that clears cookies (and more) @@ -43,6 +43,11 @@ .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. @@ -64,7 +69,7 @@ \fBbisc.conf\fR(5) for the bisc configuration file .SH AUTHORS -Copyright © 2021 Michele Guerini Rocco. +Copyright © 2022 Michele Guerini Rocco. .TP 0 Released under the GPL, version 3 or greater. This software carries no warranty of any kind. diff --git a/man/bisc.conf.5 b/man/bisc.conf.5 --- a/man/bisc.conf.5 +++ b/man/bisc.conf.5 @@ -1,4 +1,4 @@ -.TH bisc.conf 5 "Semptember 7, 2021" "bisc 0.4.0" +.TH bisc.conf 5 "January 11, 2022" "bisc 0.4.1" .SH NAME bisc.conf - bisc configuration file @@ -43,7 +43,7 @@ \fBbisc\fR(1) for the bisc command .SH AUTHORS -Copyright © 2021 Michele Guerini Rocco. +Copyright © 2022 Michele Guerini Rocco. .TP 0 Released under the GPL, version 3 or greater. This software carries no warranty of any kind.