.gitignore

@@ -1,4 +1 @@
 dist
-dist-newstyle
-result
-bisc.nix

Main.hs

@@ -4,12 +4,10 @@
 {-# LANGUAGE OverloadedLabels    #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiWayIf          #-}
 
 -- Databases
-import Database.Selda               (Text, liftIO, (!))
+import Database.Selda        (Text, liftIO, (!))
-import Database.Selda.SQLite        (withSQLite)
+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
@@ -34,11 +32,8 @@ 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, isInfixOf)
+import Data.List             (nub)
 import Data.Maybe            (mapMaybe)
 import Data.Function         ((&))
 import Data.Default          (def)
@@ -61,7 +56,6 @@ 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
   }
 
@@ -81,13 +75,6 @@ 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'
@@ -195,27 +182,23 @@ actions =
   , ("SessionStorage", deleteSessionStorage)
   ]
 
-
 -- | Deletes records in the Cookies database
 deleteCookies :: Action Result
 deleteCookies = do
-  dir <- asks webenginePath
+  database <- (</> "Cookies") <$> 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
-  withoutLocks "Cookies" $ \database -> do
+  CE.handle dbErrors $ withSQLite database $ do
-    CE.handle dbErrors $ withSQLite database $ do
+    bad <- S.query $ do
-      bad <- S.query $ do
+      cookie <- S.select cookies
-        cookie <- S.select cookies
+      S.restrict (by whitelist cookie)
-        S.restrict (by whitelist cookie)
+      return (cookie ! #host_key)
-        return (cookie ! #host_key)
+    when (not dry) $
-      when (not dry) $
+      S.deleteFrom_ cookies (by whitelist)
-        S.deleteFrom_ cookies (by whitelist)
+    return (length bad, nub bad)
-      return (length bad, nub bad)
   where
     by set x = S.not_ (x ! #host_key `S.isIn` set)
 
@@ -223,23 +206,20 @@ deleteCookies = do
 -- | Deletes records in the QuotaManager API database
 deleteQuotaOrigins :: Action Result
 deleteQuotaOrigins = do
-  dir <- asks webenginePath
+  database <- (</> "QuotaManager") <$> 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 mkPattern <$> asks whitelist
+  whitelist <- map pattern <$> asks whitelist
-  withoutLocks "QuotaManager" $ \database -> do
+  CE.handle dbErrors $ withSQLite database $ do
-    CE.handle dbErrors $ withSQLite database $ do
+    bad <- S.query $ do
-      bad <- S.query $ do
+      quota <- S.select quotaOrigins
-        quota <- S.select quotaOrigins
+      S.restrict (by whitelist quota)
-        S.restrict (by whitelist quota)
+      return (quota ! #origin)
-        return (quota ! #origin)
+    when (not dry) $
-      when (not dry) $
+      S.deleteFrom_ quotaOrigins (by whitelist)
-        S.deleteFrom_ quotaOrigins (by whitelist)
+    return (length bad, nub bad)
-      return (length bad, nub bad)
   where
     -- check if quota is not whitelisted
     by whitelist quota = S.not_ (S.true `S.isIn` matches)
@@ -250,7 +230,8 @@ deleteQuotaOrigins = do
           S.restrict (url `S.like` S.the pattern)
           return S.true
     -- turns domains into patterns to match a url
-    mkPattern domain = "http%://%" <> domain <> "/"
+    pattern domain = "http%://%" <> domain <> "/"
+
 
 
 -- | Deletes per-domain files under the IndexedDB directory
@@ -268,7 +249,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
@@ -309,21 +290,13 @@ 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")
 
-  -- when dry running replace the delete function with a nop
+  dry <- asks (dryRun . options)
   let delete = if dry then (\_ _ _ -> pure ()) else L.delete
 
   withDB path $ \db -> do
@@ -365,21 +338,13 @@ 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")
 
-  -- when dry running replace the delete function with a nop
+  dry <- asks (dryRun . options)
   let delete = if dry then (\_ _ _ -> pure ()) else L.delete
 
   withDB path $ \db -> do
@@ -420,50 +385,23 @@ deleteSessionStorage = do
 -- * 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 | "Corruption"  `T.isInfixOf` msg -> do
+      if not ("Corruption" `T.isInfixOf` msg)
-           -- try repairing before giving up
+        then throwError ("error opening the database:\n " <> msg)
-           liftIO $ L.repair path def
+        else liftIO $ L.repair path def >> withDB path action
-           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
@@ -480,12 +418,7 @@ loadSettings opts = do
 
   return (Settings webengine domains opts)
 
-
 -- | Catches any Selda error
 dbErrors :: S.SeldaError -> Action a
-dbErrors (S.DbError msg) = throwError $ "error opening database: " <> T.pack msg
+dbErrors e = throwError $
-dbErrors e =
+  "database operation failed: " <> T.pack (BE.displayException 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

@@ -66,7 +66,7 @@ corrupt more often, are automatically repaired by bisc.
 
 ## License
 
-Copyright (C) 2022 Michele Guerini Rocco
+Copyright (C) 2021 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

@@ -1,5 +1,5 @@
 name:                bisc
-version:             0.4.1.0
+version:             0.4.0.0
 synopsis:            A small tool that clears cookies (and more).
 description:         
 
@@ -19,7 +19,7 @@ license:             GPL-3
 license-file:        LICENSE
 author:              Michele Guerini Rocco
 maintainer:          rnhmjoj@inventati.org
-copyright:           Copyright (C) 2022 Michele Guerini Rocco
+copyright:           Copyright (C) 2021 Michele Guerini Rocco
 category:            Utility
 build-type:          Simple
 extra-source-files:  README.md, man/bisc.1 man/bisc.conf.5
@@ -37,12 +37,12 @@ executable bisc
   main-is:             Main.hs
   build-depends:       base ==4.* , selda ==0.*,
                        selda-sqlite ==0.*,
-                       leveldb-haskell ==0.*, resourcet,
+                       leveldb-haskell ==0.*,
-                       filepath, directory, text, unix,
+                       filepath, directory, text,
                        mtl, configurator, exceptions,
                        data-default, bytestring,
                        optparse-applicative
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -O2
+  ghc-options:         -Wall
   if flag(static)
     extra-libraries:   snappy stdc++

default.nix

@@ -10,7 +10,7 @@ let
   basepkgs = import nixpkgs { inherit system; };
   pkgs = if static then basepkgs.pkgsStatic else basepkgs.pkgs;
 
-  ghc = if static then pkgs.haskell.packages.integer-simple.ghc901
+  ghc =  if static then pkgs.haskell.packages.integer-simple.ghc8104
     else if compiler == "default" then pkgs.haskellPackages
     else pkgs.haskell.packages.${compiler};
 

man/bisc.1

@@ -1,4 +1,4 @@
-.TH bisc 1 "January 11, 2022" "bisc 0.4.1" "User Commands"
+.TH bisc 1 "Semptember 7, 2021" "bisc 0.4.0" "User Commands"
 
 .SH NAME
 bisc - a small tool that clears cookies (and more)
@@ -43,11 +43,6 @@ 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.
 
@@ -69,7 +64,7 @@ $HOME/.config and $HOME/.local/share respectively, will be used instead.
 \fBbisc.conf\fR(5) for the bisc configuration file
 
 .SH AUTHORS
-Copyright © 2022 Michele Guerini Rocco.
+Copyright © 2021 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

@@ -1,4 +1,4 @@
-.TH bisc.conf 5 "January 11, 2022" "bisc 0.4.1"
+.TH bisc.conf 5 "Semptember 7, 2021" "bisc 0.4.0"
 
 .SH NAME
 bisc.conf - bisc configuration file
@@ -43,7 +43,7 @@ webengine-path = "$(HOME)/.local/qutebrowser/webengine"
 \fBbisc\fR(1) for the bisc command
 
 .SH AUTHORS
-Copyright © 2022 Michele Guerini Rocco.
+Copyright © 2021 Michele Guerini Rocco.
 .TP 0
 Released under the GPL, version 3 or greater.
 This software carries no warranty of any kind.