diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -5,41 +5,87 @@ {-# 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.Exit as E -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 +-- Version information +import qualified Paths_bisc as Bisc +import Data.Version (showVersion) --- | Bisc settings +-- 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, ()) + + +-- 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 + { version :: Bool -- ^ print version number + , 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 "version" + <> O.short 'v' + <> O.help "Print the version number and exit" + ) + <*> 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 -- | Just a cookie @@ -68,6 +114,7 @@ quotaOrigins :: S.Table QuotaOrigin quotaOrigins = S.table "OriginInfoTable" [] + -- | Main monad stack -- -- * 'ReaderT' for accessing settings @@ -83,38 +130,63 @@ -- | Clears all means of permanent storage main :: IO () main = do - config <- D.getXdgDirectory D.XdgConfig ("bisc" "bisc.conf") - run <- runAction <$> loadSettings config - run "Cookies" deleteCookies - run "QuotaManager" deleteQuotaOrigins - run "IndexedDB" deleteIndexedDB - run "LocalStorage" deleteLocalStorage - run "SessionStorage" deleteSessionStorage + defConfig <- D.getXdgDirectory D.XdgConfig ("bisc" "bisc.conf") + opts <- O.execParser (cliParser defConfig) + when (version opts) $ do + putStrLn ("bisc " <> showVersion Bisc.version) + E.exitSuccess + run <- runAction <$> loadSettings opts + numFailures <- sum <$> mapM (uncurry run) actions + + if numFailures == 0 + then E.exitSuccess + else do + putStrLn ("\nwarning: " <> show numFailures <> " actions have failed") + E.exitWith (E.ExitFailure numFailures) + + -- | Runs an 'Action' and pretty-prints the results -runAction :: Settings -> Text -> Action Result -> IO () +runAction :: Settings -> Text -> Action Result -> IO Int runAction settings name x = do a <- BE.try $ runExceptT (runReaderT x settings) case a of - Right (Right res) -> printResult res - Right (Left msg) -> printFailed msg - Left (err :: BE.IOException) -> printFailed (T.pack $ BE.displayException err) + Right (Right res) -> printResult res >> return 0 + Right (Left msg) -> printFailed msg >> return 1 + Left (err :: BE.IOException) -> + printFailed (T.pack $ BE.displayException err) >> return 1 where - printFailed msg = T.putStrLn ("- " <> name <> " cleaning failed:\n " <> msg) + printFailed msg = + T.putStrLn ("- " <> name <> " cleaning failed:\n " <> msg) printResult (n, bad) | n > 0 = do - T.putStrLn ("- " <> name <> ": deleted " <> T.pack (show n) <> " entries for:") + T.putStrLn ("- " <> name <> ": " <> verb <> + " " <> T.pack (show n) <> " entries for:") T.putStrLn (T.unlines $ map (" * " <>) bad) | otherwise = T.putStrLn ("- " <> name <> ": nothing to delete") + verb = if (dryRun . options $ settings) + then "would delete" + else "deleted" -- * Cleaning actions +-- | List of actions and their names +actions :: [(Text, Action Result)] +actions = + [ ("Cookies", deleteCookies) + , ("QuotaManager", deleteQuotaOrigins) + , ("IndexedDB", deleteIndexedDB) + , ("LocalStorage", deleteLocalStorage) + , ("SessionStorage", deleteSessionStorage) + ] + -- | 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 +196,9 @@ 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 +206,8 @@ -- | 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 +217,9 @@ 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 +244,7 @@ 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 +253,8 @@ 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 +270,8 @@ 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 +296,15 @@ 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 +312,7 @@ & 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 +344,9 @@ 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 +360,7 @@ 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 +369,7 @@ & 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 +402,21 @@ 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,29 +2,28 @@ ### A small tool that clears cookies (and more) -Websites can store unwanted data using all sorts of methods: besides -the usual cookies, there are also the local and session storage, the -IndexedDB API and more caches as well. +Websites can store unwanted data using all sorts of methods: besides the usual +cookies, there are also the local and session storage, the IndexedDB API and +more caches as well. bisc will try to go through each of them and remove all information from websites that are not explicitly allowed (ie. a whitelist of domains). -It was created for qutebrowser, but it actually supports the storage -format used by Chromium-based browsers, which (sadly) means almost -every one nowadays. +It was created for qutebrowser, but it actually supports the storage format +used by Chromium-based browsers, which (sadly) means almost every one nowadays. ## Installation -bisc is a Haskell program available on [Hackage][hackage] and can -be installed with one of the Haskell package managers. For -example, with [cabal-install][cabal] you would do +bisc is a Haskell program available on [Hackage][hackage] and can be installed +with one of the Haskell package managers. For example, with +[cabal-install][cabal] you would do ``` cabal install bisc ``` and similarly for [stack][stack]. -Alternatively, if you are using Nix or NixOS, bisc is available -under the attribute `haskellPackages.bisc`. It should also be in -the Nix binary cache so you don't have to build from source. +Alternatively, if you are using Nix or NixOS, bisc is available under the +attribute `haskellPackages.bisc`. It should also be in the Nix binary cache so +you don't have to build from source. Finally, statically compiled binaries can be found in the [releases](/git/rnhmjoj/bisc/releases). @@ -35,26 +34,29 @@ ## Configuration -The bisc configuration file is `$XDG_CONFIG_HOME/bisc/bisc.conf`. -It allows to change the paths of the QtWebEngine/Chromium -directory and the whitelist file. +The bisc configuration file is `$XDG_CONFIG_HOME/bisc/bisc.conf`. It allows to +change the paths of the QtWebEngine/Chromium directory and the whitelist file. The default settings are: ``` whitelist-path = "$(XDG_CONFIG_HOME)/qutebrowser/whitelists/cookies" webengine-path = "$(XDG_DATA_HOME)/qutebrowser/webengine" ``` +If you want a different location for the configuration file, you can change it +using the `--config` command line option. + ## Usage -Create an empty whitelist file and write the domains of the -allowed cookies, one per line. +- Create an empty whitelist file and write the domains of the allowed cookies, + one per line. Eg. ``` .example.com example.com ``` -Run `bisc` to delete all non-whitelisted data from qutebrowser. +- Run `bisc --dry-run` to see what would be deleted without actually doing it. +- Run `bisc` to delete all non-whitelisted data from qutebrowser. Note that running bisc while the browser is open is not safe: this means it could possibly **corrupt** the databases. Hoever, corruption in the sqllite diff --git a/bisc.cabal b/bisc.cabal --- a/bisc.cabal +++ b/bisc.cabal @@ -1,5 +1,5 @@ name: bisc -version: 0.3.1.0 +version: 0.4.0.0 synopsis: A small tool that clears cookies (and more). description: @@ -22,13 +22,17 @@ copyright: Copyright (C) 2021 Michele Guerini Rocco category: Utility build-type: Simple -extra-source-files: README.md +extra-source-files: README.md, man/bisc.1 man/bisc.conf.5 cabal-version: >=1.10 source-repository head type: git location: https://maxwell.ydns.eu/git/rnhmjoj/bisc +flag static + default: False + description: Create a statically-linked binary + executable bisc main-is: Main.hs build-depends: base ==4.* , selda ==0.*, @@ -36,6 +40,9 @@ leveldb-haskell ==0.*, filepath, directory, text, mtl, configurator, exceptions, - data-default, bytestring + data-default, bytestring, + optparse-applicative default-language: Haskell2010 - extra-libraries: snappy stdc++ + ghc-options: -Wall + if flag(static) + extra-libraries: snappy stdc++ diff --git a/man/bisc.1 b/man/bisc.1 new file mode 100644 --- /dev/null +++ b/man/bisc.1 @@ -0,0 +1,70 @@ +.TH bisc 1 "Semptember 7, 2021" "bisc 0.4.0" "User Commands" + +.SH NAME +bisc - a small tool that clears cookies (and more) + +.SH SYNOPSIS +.B bisc +.RI [ option ] + +.SH DESCRIPTION +.PP +Websites can store unwanted data using all sorts of methods: besides the usual +cookies, there are also the local and session storage, the IndexedDB API and +more caches as well. +.PP +Bisc will try to go through each of them and remove all information from +websites that are not explicitly allowed (ie. a whitelist of domains). +It was created for qutebrowser, but it actually supports the storage format +used by Chromium-based browsers, which (sadly) means almost every one nowadays. + +.SH USAGE +.IP \(bu 2 +Create an empty whitelist file (see the FILES section) and write the domains of +the allowed cookies, one per line. For example: +.IP +.nf +\fC +\&.example.com +example.com +\fR +.fi +.IP \(bu 2 +Run \fCbisc --dry-run\fR to see what would be deleted without actually +doing it. +.IP \(bu 2 +Run \fCbisc\fR to delete all non-whitelisted data from qutebrowser. + +.SH OPTIONS +.TP +.BR -c ","\ --config\ FILE +Use FILE as the configuration file. +.TP +.BR -n ","\ --dry-run +Don't actually remove anything, just show what would be done. +.TP +.BR -h ","\ --help +Show the program information and help screen. + +.SH FILES +.TP +.I $XDG_CONFIG_HOME/bisc/bisc.conf +Bisc configuration +.TP +.I $XDG_CONFIG_HOME/qutebrowser/whitelists/cookies +Domain whitelist +.TP +.I $XDG_DATA_HOME/qutebrowser/webengine +Chromium/QtWebEngine state directory +.PP +Note: when the variable $XDG_CONFIG_HOME or $XDG_DATA_HOME is not set, +$HOME/.config and $HOME/.local/share respectively, will be used instead. + +.SH SEE ALSO +\fBbisc.conf\fR(5) for the bisc configuration file + +.SH AUTHORS +Copyright © 2021 Michele Guerini Rocco. +.TP 0 +Released under the GPL, version 3 or greater. +This software carries no warranty of any kind. diff --git a/man/bisc.conf.5 b/man/bisc.conf.5 new file mode 100644 --- /dev/null +++ b/man/bisc.conf.5 @@ -0,0 +1,49 @@ +.TH bisc.conf 5 "Semptember 7, 2021" "bisc 0.4.0" + +.SH NAME +bisc.conf - bisc configuration file + +.SH SYNOPSIS + +The bisc configuration file, found at the following locations, unless specified +via the \fC-c\fR command line option: +.IP \(bu 3 +$XDG_CONFIG_HOME/bisc/bisc.conf, +.IP \(bu 3 +$HOME/.config/bisc/bisc.conf (when $XDG_CONFIG_HOME is not set) + +.SH DESCRIPTION +.PP +The bisc.conf file allows to change the default location of a couple of files +used by bisc. + +.SH OPTIONS + +.TP 4 +.BR "webengine-path" " (default " "$(XDG_DATA_HOME)/qutebrowser/webengine") +The location of the Chromium/QtWebEngine state directory. +.TP 4 +.BR "whitelist-path" " (default " "$(XDG_CONFIG_HOME)/qutebrowser/whitelists/cookies") +The location of the domain whitelist. + +.SH EXAMPLE + +This is an example configuration: +.IP +.nf +\fC +# This is a comment +whitelist-path = "/home/alice/docs/cookie-whitelist" +# You can also access environment variables: +webengine-path = "$(HOME)/.local/qutebrowser/webengine" +\fR +.fi + +.SH SEE ALSO +\fBbisc\fR(1) for the bisc command + +.SH AUTHORS +Copyright © 2021 Michele Guerini Rocco. +.TP 0 +Released under the GPL, version 3 or greater. +This software carries no warranty of any kind.