|
|
|
@ -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
|
|
|
|
|
|
|
|
|
|
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 (mapM_, 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
|
|
|
|
@ -104,9 +142,13 @@ runAction settings name x = do
|
|
|
|
|
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
|
|
|
|
@ -114,7 +156,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 +167,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 +177,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,14 +188,21 @@ deleteQuotaOrigins = do
|
|
|
|
|
quota <- S.select quotaOrigins
|
|
|
|
|
S.restrict (by whitelist quota)
|
|
|
|
|
return (quota ! #origin)
|
|
|
|
|
n <- S.deleteFrom quotaOrigins (by whitelist)
|
|
|
|
|
when (not dry) $
|
|
|
|
|
S.deleteFrom_ cookies (by whitelist)
|
|
|
|
|
return (n, nub bad)
|
|
|
|
|
where
|
|
|
|
|
-- check if x ∉ set
|
|
|
|
|
by set x = S.not_ . any_ . map (S.like (x ! #origin)) $ set
|
|
|
|
|
-- check if quota is not whitelisted
|
|
|
|
|
by whitelist quota = S.not_ (S.true `S.isIn` matches)
|
|
|
|
|
where
|
|
|
|
|
url = quota ! #origin
|
|
|
|
|
matches = do
|
|
|
|
|
pattern <- S.selectValues (map S.Only whitelist)
|
|
|
|
|
S.restrict (url `S.like` S.the pattern)
|
|
|
|
|
return S.true
|
|
|
|
|
-- turns domains into patterns to match a url
|
|
|
|
|
pattern domain = S.text ("http%://%" <> domain <> "/")
|
|
|
|
|
any_ = foldl' (.||) S.false
|
|
|
|
|
pattern domain = "http%://%" <> domain <> "/"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Deletes per-domain files under the IndexedDB directory
|
|
|
|
@ -163,6 +215,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"
|
|
|
|
|
|
|
|
|
@ -171,7 +224,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]
|
|
|
|
@ -187,8 +241,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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -213,12 +267,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 ->
|
|
|
|
@ -226,7 +283,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)
|
|
|
|
@ -258,6 +315,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 ->
|
|
|
|
@ -271,7 +331,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
|
|
|
|
@ -280,7 +340,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)
|
|
|
|
@ -313,21 +373,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
|
|
|
|
|