add option to bypass locks

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
+  context $ \database -> do
-    bad <- S.query $ do
+    CE.handle dbErrors $ withSQLite database $ do
-      cookie <- S.select cookies
+      bad <- S.query $ do
-      S.restrict (by whitelist cookie)
+        cookie <- S.select cookies
-      return (cookie ! #host_key)
+        S.restrict (by whitelist cookie)
-    when (not dry) $
+        return (cookie ! #host_key)
-      S.deleteFrom_ cookies (by whitelist)
+      when (not dry) $
-    return (length bad, nub bad)
+        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
+  context $ \database -> do
-    bad <- S.query $ do
+    CE.handle dbErrors $ withSQLite database $ do
-      quota <- S.select quotaOrigins
+      bad <- S.query $ do
-      S.restrict (by whitelist quota)
+        quota <- S.select quotaOrigins
-      return (quota ! #origin)
+        S.restrict (by whitelist quota)
-    when (not dry) $
+        return (quota ! #origin)
-      S.deleteFrom_ quotaOrigins (by whitelist)
+      when (not dry) $
-    return (length bad, nub bad)
+        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)
+      if | "Corruption"  `T.isInfixOf` msg -> do
-        then throwError ("error opening the database:\n " <> msg)
+           -- try repairing before giving up
-        else liftIO $ L.repair path def >> withDB path action
+           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 $
+dbErrors (S.DbError msg) = throwError $ "error opening database: " <> T.pack msg
-  "database operation failed: " <> T.pack (BE.displayException e)
+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

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.