add option to bypass locks
parent
41feee9b37
commit
05e930a0a5
GPG Key ID:
BFBAF4C975F76450
131
Main.hs
131
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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue