diff --git a/Main.hs b/Main.hs index 3e831d6..d972f69 100644 --- a/Main.hs +++ b/Main.hs @@ -5,40 +5,75 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -import Data.List (nub, foldl') -import Data.Maybe (mapMaybe) -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, (.||), (!)) +-- Databases +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 -import Control.Exception as BE -import Control.Monad.Catch as CE +-- Error handling +import Control.Exception as BE +import Control.Monad.Catch as CE -import qualified System.Directory as D -import qualified Data.Configurator as C +-- 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") - run <- runAction <$> loadSettings config + defConfig <- D.getXdgDirectory D.XdgConfig ("bisc" "bisc.conf") + opts <- O.execParser (cliParser defConfig) + + run <- runAction <$> loadSettings opts run "Cookies" deleteCookies run "QuotaManager" deleteQuotaOrigins run "IndexedDB" deleteIndexedDB @@ -114,7 +152,8 @@ runAction settings name x = do -- | Deletes records in the Cookies database deleteCookies :: Action Result deleteCookies = do - database <- ( "Cookies") <$> asks webenginePath + 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) - return (n, nub bad) + 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) @@ -133,7 +173,8 @@ deleteCookies = do -- | Deletes records in the QuotaManager API database deleteQuotaOrigins :: Action Result deleteQuotaOrigins = do - database <- ( "QuotaManager") <$> asks webenginePath + 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) - return (n, nub bad) + 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) @@ -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,7 +220,8 @@ deleteIndexedDB = do let badFiles = filterMaybe (fmap unlisted . domain) entries badDomains = mapMaybe domain badFiles - liftIO $ mapM_ D.removePathForcibly badFiles + when (not dry) $ + liftIO $ mapM_ D.removePathForcibly badFiles return (length badFiles, nub badDomains) where listDirectoryAbs :: FilePath -> Action [FilePath] @@ -193,8 +237,8 @@ deleteIndexedDB = do domain :: FilePath -> Maybe Text domain = extract . url where extract [] = Nothing - extract (x:[]) = Nothing - extract (x:xs) = Just $ T.unwords (init xs) + extract (_:[]) = Nothing + 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 -loadSettings :: FilePath -> IO Settings -loadSettings path = do +-- | Loads the config file/cli options +loadSettings :: Options -> IO Settings +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 diff --git a/bisc.cabal b/bisc.cabal index 0526372..a0489c8 100644 --- a/bisc.cabal +++ b/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++ diff --git a/default.nix b/default.nix index 6982ba0..d965b7b 100644 --- a/default.nix +++ b/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 [