add config and dry-run options

Main.hs

@@ -5,40 +5,75 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-import Data.List             (nub, foldl')
+-- Databases
-import Data.Maybe            (mapMaybe)
+import Database.Selda        (Text, liftIO, (!))
-import Data.Function         ((&))
-import Data.Default          (def)
-import Data.Text.Encoding    (decodeUtf8)
-import Control.Monad         (mapM_, when, (>=>))
-import Control.Monad.Reader  (ReaderT, runReaderT, asks)
-import Control.Monad.Except  (ExceptT, runExceptT, throwError)
-import System.FilePath       (joinPath, takeBaseName, (</>))
-import Database.Selda        (Text, liftIO, (.||), (!))
 import Database.Selda.SQLite (withSQLite)
-
 import qualified Database.Selda             as S
 import qualified Database.LevelDB           as L
 import qualified Database.LevelDB.Streaming as LS
 
+-- Error handling
 import Control.Exception   as BE
 import Control.Monad.Catch as CE
 
+-- Configuration
+import qualified Options.Applicative as O
 import qualified System.Directory    as D
 import qualified Data.Configurator   as C
+
+-- Text converion
+import Data.Text.Encoding  (decodeUtf8)
 import qualified Data.Text         as T
 import qualified Data.Text.IO      as T
 import qualified Data.ByteString   as B
 
-import Debug.Trace
+-- Misc
+import Data.List             (nub)
+import Data.Maybe            (mapMaybe)
+import Data.Function         ((&))
+import Data.Default          (def)
+import Control.Monad         (when)
+import Control.Monad.Reader  (ReaderT, runReaderT, asks)
+import Control.Monad.Except  (ExceptT, runExceptT, throwError)
+import System.FilePath       (joinPath, takeBaseName, (</>))
 
--- | Bisc settings
+
+-- Options
+
+-- | Configuration file settings
 data Settings = Settings
-  { whitelistPath :: FilePath  -- ^ whitelist file
+  { webenginePath :: FilePath  -- ^ webengine data directory
-  , webenginePath :: FilePath  -- ^ webengine data directory
   , whitelist     :: [Text]    -- ^ whitelisted domains
+  , options       :: Options   -- ^ cli options
   }
 
+-- | Command line options
+data Options = Options
+  { dryRun     :: Bool      -- ^ don't delete anything
+  , configPath :: FilePath  -- ^ config file path
+  }
+
+-- | Command line parser
+cliParser :: FilePath -> O.ParserInfo Options
+cliParser defConfig = O.info (O.helper <*> parser) infos
+  where
+    parser = Options
+      <$> O.switch
+          (  O.long "dry-run"
+          <> O.short 'n'
+          <> O.help ("Don't actually remove anything, "<>
+                     "just show what would be done")
+          )
+      <*> O.strOption
+          (  O.long "config"
+          <> O.short 'c'
+          <> O.value defConfig
+          <> O.help "Specify a configuration file"
+          )
+    infos  =
+      O.fullDesc <>
+      O.progDesc "A small tool that clears cookies (and more)"
+
 
 -- SQL records
 
@@ -68,6 +103,7 @@ cookies = S.table "cookies" []
 quotaOrigins :: S.Table QuotaOrigin
 quotaOrigins = S.table "OriginInfoTable" []
 
+
 -- | Main monad stack
 --
 -- * 'ReaderT' for accessing settings
@@ -83,8 +119,10 @@ type Result = (Int, [Text])
 -- | Clears all means of permanent storage
 main :: IO ()
 main = do
-  config <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
+  defConfig <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
-  run <- runAction <$> loadSettings config
+  opts <- O.execParser (cliParser defConfig)
+
+  run <- runAction <$> loadSettings opts
   run "Cookies" deleteCookies
   run "QuotaManager" deleteQuotaOrigins
   run "IndexedDB" deleteIndexedDB
@@ -115,6 +153,7 @@ runAction settings name x = do
 deleteCookies :: Action Result
 deleteCookies = do
   database <- (</> "Cookies") <$> asks webenginePath
+  dry <- asks (dryRun . options)
   exists <- liftIO $ D.doesFileExist database
   when (not exists) (throwError "database is missing")
 
@@ -124,8 +163,9 @@ deleteCookies = do
       cookie <- S.select cookies
       S.restrict (by whitelist cookie)
       return (cookie ! #host_key)
-    n <- S.deleteFrom cookies (by whitelist)
+    when (not dry) $
-    return (n, nub bad)
+      S.deleteFrom_ cookies (by whitelist)
+    return (length bad, nub bad)
   where
     by set x = S.not_ (x ! #host_key `S.isIn` set)
 
@@ -134,6 +174,7 @@ deleteCookies = do
 deleteQuotaOrigins :: Action Result
 deleteQuotaOrigins = do
   database <- (</> "QuotaManager") <$> asks webenginePath
+  dry <- asks (dryRun . options)
   exists <- liftIO $ D.doesFileExist database
   when (not exists) (throwError "database is missing")
 
@@ -143,8 +184,9 @@ deleteQuotaOrigins = do
       quota <- S.select quotaOrigins
       S.restrict (by whitelist quota)
       return (quota ! #origin)
-    n <- S.deleteFrom quotaOrigins (by whitelist)
+    when (not dry) $
-    return (n, 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)
@@ -169,6 +211,7 @@ deleteQuotaOrigins = do
 deleteIndexedDB :: Action Result
 deleteIndexedDB = do
   webengine <- asks webenginePath
+  dry <- asks (dryRun . options)
   exists <- liftIO $ D.doesDirectoryExist (webengine </> "IndexedDB")
   when (not exists) $ throwError "directory is missing"
 
@@ -177,6 +220,7 @@ deleteIndexedDB = do
   let
     badFiles   = filterMaybe (fmap unlisted . domain) entries
     badDomains = mapMaybe domain badFiles
+  when (not dry) $
     liftIO $ mapM_ D.removePathForcibly badFiles
   return (length badFiles, nub badDomains)
   where
@@ -193,8 +237,8 @@ deleteIndexedDB = do
     domain :: FilePath -> Maybe Text
     domain = extract . url where
       extract    []  = Nothing
-      extract (x:[]) = Nothing
+      extract (_:[]) = Nothing
-      extract (x:xs) = Just $ T.unwords (init xs)
+      extract (_:xs) = Just $ T.unwords (init xs)
       url = T.splitOn "_" . T.pack . takeBaseName
 
 
@@ -219,12 +263,15 @@ deleteLocalStorage = do
   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)
+  let delete = if dry then (\_ _ _ -> pure ()) else L.delete
+
   withDB path $ \db -> do
     badDomains <- L.withIterator db def $ \i ->
          LS.keySlice i LS.AllKeys LS.Asc
        & LS.filter (\k -> "META:" `B.isPrefixOf ` k
                        && (metaDomain k) `notElem` whitelist)
-       & LS.mapM (\k -> L.delete db def k >> return (metaDomain k))
+       & LS.mapM (\k -> delete db def k >> return (metaDomain k))
        & LS.toList
 
     n <- L.withIterator db def $ \i ->
@@ -232,7 +279,7 @@ deleteLocalStorage = do
        & LS.filter (\k -> "_" `B.isPrefixOf` k
                        && "\NUL\SOH" `B.isInfixOf` k
                        && (recDomain k) `notElem` whitelist)
-       & LS.mapM (L.delete db def)
+       & LS.mapM (delete db def)
        & LS.length
 
     return (n, badDomains)
@@ -264,6 +311,9 @@ deleteSessionStorage = do
   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)
+  let delete = if dry then (\_ _ _ -> pure ()) else L.delete
+
   withDB path $ \db -> do
     -- map of id -> isBad
     badMap <- L.withIterator db def $ \i ->
@@ -277,7 +327,7 @@ deleteSessionStorage = do
          LS.keySlice i LS.AllKeys LS.Asc
        & LS.filter (B.isPrefixOf "namespace")
        & LS.filter (isBad whitelist)
-       & LS.mapM (\k -> L.delete db def k >> return (domain k))
+       & LS.mapM (\k -> delete db def k >> return (domain k))
        & LS.toList
 
     -- and their records
@@ -286,7 +336,7 @@ deleteSessionStorage = do
        & LS.filter (B.isPrefixOf "map-")
        & LS.mapM (\k ->
          case lookup (originId k) badMap of
-           Just True -> L.delete db def k >> return 1
+           Just True -> delete db def k >> return 1
            _ -> return 0)
        & LS.sum
     return (n, nub badDomains)
@@ -319,21 +369,21 @@ withRetryDB path action = do
         else liftIO $ L.repair path def >> withDB path action
       where msg = T.pack (BE.displayException e)
 
--- | Loads the config from a file
+-- | Loads the config file/cli options
-loadSettings :: FilePath -> IO Settings
+loadSettings :: Options -> IO Settings
-loadSettings path = do
+loadSettings opts = do
   configdir <- D.getXdgDirectory D.XdgConfig "qutebrowser"
   datadir   <- D.getXdgDirectory D.XdgData   "qutebrowser"
   let
    defaultWhitelist = joinPath [configdir, "whitelists", "cookies"]
    defaultWebengine = joinPath [datadir, "webengine"]
 
-  config    <- C.load [C.Optional path]
+  config    <- C.load [C.Optional (configPath opts)]
   whitelist <- C.lookupDefault defaultWhitelist config "whitelist-path"
   webengine <- C.lookupDefault defaultWebengine config "webengine-path"
   domains   <- T.lines <$> T.readFile whitelist
 
-  return (Settings whitelist webengine domains)
+  return (Settings webengine domains opts)
 
 -- | Catches any Selda error
 dbErrors :: S.SeldaError -> Action a

bisc.cabal

@@ -36,6 +36,7 @@ executable bisc
                        leveldb-haskell ==0.*,
                        filepath, directory, text,
                        mtl, configurator, exceptions,
-                       data-default, bytestring
+                       data-default, bytestring,
+                       optparse-applicative
   default-language:    Haskell2010
   extra-libraries:     snappy stdc++

default.nix

@@ -12,7 +12,7 @@ let
 
   f = { mkDerivation, base, bytestring, configurator, data-default
       , directory, exceptions, filepath, leveldb-haskell, mtl, selda
-      , selda-sqlite , lib, text
+      , selda-sqlite, lib, text, optparse-applicative
       }:
       mkDerivation {
         pname = "bisc";
@@ -23,6 +23,7 @@ let
         executableHaskellDepends = [
           base bytestring configurator data-default directory exceptions
           filepath leveldb-haskell mtl selda selda-sqlite text
+          optparse-applicative
         ];
         executableSystemDepends = [ pkgs.snappy ];
         buildFlags = lib.optionals static [