rnhmjoj/bisc
1
1
Fork 0
Code Issues Pull Requests Releases 5 Wiki Activity

add config and dry-run options

Browse Source
This commit is contained in:
Michele Guerini Rocco 2021-09-06 00:02:14 +02:00
parent 892d46f005
commit 5de13cdc3d
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450
3 changed files with 93 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
Main.hs
View File

@ -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
-- 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")
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
@ -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)
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)
@ -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)
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,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 (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

3
bisc.cabal
View File

@ -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++

3
default.nix
View File

@ -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 [