add config and dry-run options
parent
892d46f005
commit
5de13cdc3d
GPG Key ID:
BFBAF4C975F76450
128
Main.hs
128
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
|
||||
|
|
|
|||
|
|
@ -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++
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
Loading…
Reference in New Issue