bisc 0.4.0.0 → 0.4.1.0
raw patch · 5 files changed
+120/−48 lines, 5 filesdep +resourcetdep +unix
Dependencies added: resourcet, unix
Files
- Main.hs +105/−38
- README.md +1/−1
- bisc.cabal +5/−5
- man/bisc.1 +7/−2
- man/bisc.conf.5 +2/−2
Main.hs view
@@ -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
README.md view
@@ -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
bisc.cabal view
@@ -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++
man/bisc.1 view
@@ -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.
man/bisc.conf.5 view
@@ -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.