bisc-0.4.1.0: Main.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
-- Databases
import Database.Selda (Text, liftIO, (!))
import Database.Selda.SQLite (withSQLite)
import Control.Monad.Trans.Resource (ResourceT)
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.Exit as E
-- 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
-- Version information
import qualified Paths_bisc as Bisc
import Data.Version (showVersion)
-- File locking bypass
import qualified System.Posix.Files as Posix
-- Misc
import Data.List (nub, isInfixOf)
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
{ 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
, unsafe :: Bool -- ^ ignore locks
, 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.switch
( O.long "unsafe"
<> O.short 'u'
<> O.help ("Ignore database locks. " <>
"This will probably corrupt the databases, but " <>
"works while the browser is running.")
)
<*> 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
data Cookie = Cookie
{ host_key :: Text -- ^ cookie domain
, creation_utc :: Int -- ^ creation date
} deriving (S.Generic, Show)
-- | The origin (domain) of a quota
data QuotaOrigin = QuotaOrigin
{ origin :: Text -- ^ URL
, last_modified_time :: Int -- ^ creation date
} deriving (S.Generic, Show)
instance S.SqlRow Cookie
instance S.SqlRow QuotaOrigin
-- SQL tables
-- | Cookies table
cookies :: S.Table Cookie
cookies = S.table "cookies" []
-- | QuotaManager origins table
quotaOrigins :: S.Table QuotaOrigin
quotaOrigins = S.table "OriginInfoTable" []
-- | Main monad stack
--
-- * 'ReaderT' for accessing settings
-- * 'ExceptT' for custom errors
type Action = ReaderT Settings (ExceptT Text IO)
-- | Number of removed domains, list of domains
type Result = (Int, [Text])
-- * Main
-- | Clears all means of permanent storage
main :: IO ()
main = do
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 Int
runAction settings name x = do
a <- BE.try $ runExceptT (runReaderT x settings)
case a of
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)
printResult (n, bad)
| n > 0 = do
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
dir <- asks webenginePath
dry <- asks (dryRun . options)
-- check for database
exists <- liftIO $ D.doesFileExist (dir </> "Cookies")
when (not exists) (throwError "database is missing")
whitelist <- map S.text <$> asks whitelist
withoutLocks "Cookies" $ \database -> do
CE.handle dbErrors $ withSQLite database $ do
bad <- S.query $ do
cookie <- S.select cookies
S.restrict (by whitelist cookie)
return (cookie ! #host_key)
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)
-- | Deletes records in the QuotaManager API database
deleteQuotaOrigins :: Action Result
deleteQuotaOrigins = do
dir <- asks webenginePath
dry <- asks (dryRun . options)
-- check for database
exists <- liftIO $ D.doesFileExist (dir </> "QuotaManager")
when (not exists) (throwError "database is missing")
whitelist <- map mkPattern <$> asks whitelist
withoutLocks "QuotaManager" $ \database -> do
CE.handle dbErrors $ withSQLite database $ do
bad <- S.query $ do
quota <- S.select quotaOrigins
S.restrict (by whitelist quota)
return (quota ! #origin)
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)
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
mkPattern domain = "http%://%" <> domain <> "/"
-- | Deletes per-domain files under the IndexedDB directory
--
-- For example:
--
-- https_example.com_0.indexeddb.leveldb
-- https_www.example.com_0.indexeddb.leveldb
--
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"
entries <- listDirectoryAbs (webengine </> "IndexedDB")
unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist
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
listDirectoryAbs :: FilePath -> Action [FilePath]
listDirectoryAbs dir = liftIO $ map (dir </>) <$> D.listDirectory dir
maybeToBool :: Maybe Bool -> Bool
maybeToBool Nothing = False
maybeToBool (Just x) = x
filterMaybe :: (a -> Maybe Bool) -> [a] -> [a]
filterMaybe f = filter (maybeToBool . f)
domain :: FilePath -> Maybe Text
domain = extract . url where
extract [] = Nothing
extract (_:[]) = Nothing
extract (_:xs) = Just $ T.unwords (init xs)
url = T.splitOn "_" . T.pack . takeBaseName
-- | Deletes records from the local storage levelDB database
--
-- The schema consists of two (or more) records for each url:
--
-- "META:<url>" which stores metadata
-- "_<url>\NUL\SOH<key>" which stores the actual data
--
-- See https://source.chromium.org/chromium/chromium/src/+/master:components/services/storage/dom_storage/local_storage_impl.cc;l=51
--
deleteLocalStorage :: Action Result
deleteLocalStorage = do
webengine <- asks webenginePath
whitelist <- asks whitelist
let path = webengine </> "Local Storage" </> "leveldb"
dry <- asks (dryRun . options)
unsafe <- asks (unsafe . options)
when (not dry && unsafe) $ liftIO $ do
-- delete and recreate the lock file to bypass POSIX locks
D.removeFile (path </> "LOCK")
T.writeFile (path </> "LOCK") ""
dbIsOk <- liftIO $ D.doesFileExist (path </> "LOCK")
when (not dbIsOk) (throwError "database is missing or corrupted")
version <- withRetryDB path (\db -> L.get db def "VERSION")
when (version /= Just "1") (throwError "database is empty or the schema unsupported")
-- when dry running replace the delete function with a nop
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 -> delete db def k >> return (metaDomain k))
& LS.toList
n <- L.withIterator db def $ \i ->
LS.keySlice i LS.AllKeys LS.Asc
& LS.filter (\k -> "_" `B.isPrefixOf` k
&& "\NUL\SOH" `B.isInfixOf` k
&& (recDomain k) `notElem` whitelist)
& LS.mapM (delete db def)
& LS.length
return (n, badDomains)
where
-- extract domains from the keys
domain = snd . T.breakOnEnd "://" . decodeUtf8
metaDomain = domain . B.drop 5
recDomain = domain . head . B.split 0 . B.drop 1
-- | Deletes records from the session storage levelDB database
--
-- The schema consists of a map `url -> id` and records under `id`:
--
-- namespace-<session-uid>-<url> = <id>
-- map-<id>-<key> = <value>
--
-- See https://source.chromium.org/chromium/chromium/src/+/master:components/services/storage/dom_storage/session_storage_metadata.cc;l=21
--
deleteSessionStorage :: Action Result
deleteSessionStorage = do
webengine <- asks webenginePath
whitelist <- asks whitelist
let path = webengine </> "Session Storage"
dry <- asks (dryRun . options)
unsafe <- asks (unsafe . options)
when (not dry && unsafe) $ liftIO $ do
-- delete and recreate the lock file to bypass POSIX locks
D.removeFile (path </> "LOCK")
T.writeFile (path </> "LOCK") ""
dbIsOk <- liftIO $ D.doesFileExist (path </> "LOCK")
when (not dbIsOk) (throwError "database is missing or corrupted")
version <- withRetryDB path (\db -> L.get db def "version")
when (version /= Just "1") (throwError "database is empty or the schema unsupported")
-- when dry running replace the delete function with a nop
let delete = if dry then (\_ _ _ -> pure ()) else L.delete
withDB path $ \db -> do
-- map of id -> isBad
badMap <- L.withIterator db def $ \i ->
LS.keySlice i LS.AllKeys LS.Asc
& LS.filter (B.isPrefixOf "namespace")
& LS.mapM (\k -> (,) <$> L.get db def k <*> pure (isBad whitelist k))
& LS.toList
-- delete the unlisted domains map
badDomains <- L.withIterator db def $ \i ->
LS.keySlice i LS.AllKeys LS.Asc
& LS.filter (B.isPrefixOf "namespace")
& LS.filter (isBad whitelist)
& LS.mapM (\k -> delete db def k >> return (domain k))
& LS.toList
-- and their records
n <- L.withIterator db def $ \i ->
LS.keySlice i LS.AllKeys LS.Asc
& LS.filter (B.isPrefixOf "map-")
& LS.mapM (\k ->
case lookup (originId k) badMap of
Just True -> delete db def k >> return 1
_ -> return 0)
& LS.sum
return (n, nub badDomains)
where
isBad whitelist = not . flip elem whitelist . domain
-- extract domain from keys (47 = length "namespace-<uid>-")
url = decodeUtf8 . B.drop 47
domain = (!! 2). T.splitOn "/" . url
-- extract id from key: drop "map-", take until "-" (ascii 45)
originId = Just . B.takeWhile (/= 45). B.drop 4
-- * Helper functions
-- | Loads a leveldb database and runs a resourceT action
withDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withDB path f = liftIO $ L.runResourceT (L.open path def >>= f)
-- | Like 'withDB' but retry the action after repairing the db
withRetryDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
withRetryDB path action = do
res <- CE.try (withDB path action)
case res of
Right b -> return b
Left (e :: BE.IOException) ->
if | "Corruption" `T.isInfixOf` msg -> do
-- try repairing before giving up
liftIO $ L.repair path def
withDB path action
| "unavailable" `T.isInfixOf` msg ->
throwError "database is locked (in use by another process)"
| otherwise ->
throwError ("error opening the database:\n " <> msg)
where msg = T.pack (BE.displayException e)
-- | Bypass SQLite locking mechanism
--
-- SQLite manages concurrent access via POSIX locks: these are tied to a
-- specific file and pid. They can be bypassed by simply creating a hard
-- link (pointing to the same inode), editing the link and then removing it.
withoutLocks :: String -> (FilePath -> Action a) -> Action a
withoutLocks dbName cont = do
dir <- asks webenginePath
unsafe <- asks (unsafe . options)
let
real = dir </> dbName
link = real <> "-bypass"
-- bypass the SQLite POSIX locks with hard links
when unsafe $ liftIO (Posix.createLink real link)
res <- cont (if unsafe then link else real)
-- remove the hard links
when unsafe $ liftIO (Posix.removeLink link)
return res
-- | 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 (configPath opts)]
whitelist <- C.lookupDefault defaultWhitelist config "whitelist-path"
webengine <- C.lookupDefault defaultWebengine config "webengine-path"
domains <- T.lines <$> T.readFile whitelist
return (Settings webengine domains opts)
-- | Catches any Selda error
dbErrors :: S.SeldaError -> Action a
dbErrors (S.DbError msg) = throwError $ "error opening database: " <> T.pack msg
dbErrors e =
if "ErrorBusy" `isInfixOf` msg
then throwError "database is locked (in use by another process)"
else throwError $ "database operation failed: " <> T.pack msg
where msg = BE.displayException e