diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,99 +1,181 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -import Data.List (nub) -import Data.Maybe (mapMaybe) -import Data.Configurator -import Control.Monad (mapM_, filterM) -import Control.Monad.Reader (ReaderT, runReaderT, asks) -import System.FilePath (joinPath, takeBaseName, ()) -import System.IO (readFile) -import System.Directory +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, (.||), (!)) +import Database.Selda.SQLite (withSQLite) -import Database.Selda -import Database.Selda.SQLite +import qualified Database.Selda as S +import qualified Database.LevelDB as L +import qualified Database.LevelDB.Streaming as LS -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Control.Exception as BE +import Control.Monad.Catch as CE +import qualified System.Directory as D +import qualified Data.Configurator as C +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.ByteString as B +import Debug.Trace + +-- | Bisc settings data Settings = Settings - { whitelistPath :: FilePath - , webenginePath :: FilePath + { whitelistPath :: FilePath -- ^ whitelist file + , webenginePath :: FilePath -- ^ webengine data directory + , whitelist :: [Text] -- ^ whitelisted domains } + +-- SQL records + +-- | Just a cookie data Cookie = Cookie - { host_key :: Text - , creation_utc :: Int - } deriving (Generic, Show) + { host_key :: Text -- ^ cookie domain + , creation_utc :: Int -- ^ creation date + } deriving (S.Generic, Show) -instance SqlRow Cookie +-- | 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 -type Action = ReaderT Settings IO +-- 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 - config <- getXdgDirectory XdgConfig ("bisc" "bisc.conf") - settings <- loadSettings config - runReaderT clean settings + 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 -clean :: Action () -clean = do - path <- asks whitelistPath - whitelist <- liftIO (T.lines <$> T.readFile path) - (n, bad) <- deleteCookies whitelist - if (n > 0) - then do - log ("Cookies: deleted " <> num n <> " from:") - log (prettyPrint bad) - else log ("Cookies: nothing to delete.") +-- | Runs an 'Action' and pretty-prints the results +runAction :: Settings -> Text -> Action Result -> IO () +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) + where + 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 (T.unlines $ map (" * " <>) bad) + | otherwise = T.putStrLn ("- " <> name <> ": nothing to delete") - (n, bad) <- deleteData whitelist - if (n > 0) - then do - log ("Persistent data: deleted " <> num n <> " entries:") - log (prettyPrint bad) - else log ("Persistent data: nothing to delete.") - where log = liftIO . T.putStrLn - num = T.pack . show +-- * Cleaning actions +-- | Deletes records in the Cookies database +deleteCookies :: Action Result +deleteCookies = do + database <- ( "Cookies") <$> asks webenginePath + exists <- liftIO $ D.doesFileExist database + when (not exists) (throwError "database is missing") -deleteCookies :: [Text] -> Action (Int, [Text]) -deleteCookies domains = do - database <- ( "Cookies") <$> asks webenginePath - liftIO $ withSQLite database $ do - bad <- query $ do - cookie <- select cookies - restrict (by whitelist cookie) + whitelist <- map S.text <$> asks whitelist + CE.handle dbErrors $ withSQLite database $ do + bad <- S.query $ do + cookie <- S.select cookies + S.restrict (by whitelist cookie) return (cookie ! #host_key) - n <- deleteFrom cookies (by whitelist) + n <- S.deleteFrom cookies (by whitelist) return (n, nub bad) where - by set x = not_ (x ! #host_key `isIn` set) - whitelist = map text domains + by set x = S.not_ (x ! #host_key `S.isIn` set) -deleteData :: [Text] -> Action (Int, [Text]) -deleteData whitelist = do +-- | Deletes records in the QuotaManager API database +deleteQuotaOrigins :: Action Result +deleteQuotaOrigins = do + database <- ( "QuotaManager") <$> asks webenginePath + exists <- liftIO $ D.doesFileExist database + when (not exists) (throwError "database is missing") + + whitelist <- map pattern <$> asks whitelist + CE.handle dbErrors $ withSQLite database $ do + bad <- S.query $ do + quota <- S.select quotaOrigins + S.restrict (by whitelist quota) + return (quota ! #origin) + n <- S.deleteFrom quotaOrigins (by whitelist) + return (n, nub bad) + where + -- check if x ∉ set + by set x = S.not_ . any_ . map (S.like (x ! #origin)) $ set + -- turns domains into patterns to match a url + pattern domain = S.text ("http%://%" <> domain <> "/") + any_ = foldl' (.||) S.false + + +-- | 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 - appCache <- liftIO $ listDirectoryAbs (webengine "Application Cache") - indexedDB <- liftIO $ listDirectoryAbs (webengine "IndexedDB") - localStorage <- liftIO $ listDirectoryAbs (webengine "Local Storage") + 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 - entries = appCache ++ indexedDB ++ localStorage badFiles = filterMaybe (fmap unlisted . domain) entries badDomains = mapMaybe domain badFiles - liftIO $ mapM_ removePathForcibly badFiles + liftIO $ mapM_ D.removePathForcibly badFiles return (length badFiles, nub badDomains) where - listDirectoryAbs :: FilePath -> IO [FilePath] - listDirectoryAbs dir = map (dir ) <$> listDirectory dir + listDirectoryAbs :: FilePath -> Action [FilePath] + listDirectoryAbs dir = liftIO $ map (dir ) <$> D.listDirectory dir maybeToBool :: Maybe Bool -> Bool maybeToBool Nothing = False @@ -109,32 +191,145 @@ extract (x:xs) = Just $ T.unwords (init xs) url = T.splitOn "_" . T.pack . takeBaseName - unlisted = not . (`elem` whitelist) +-- | Deletes records from the local storage levelDB database +-- +-- The schema consists of two (or more) records for each url: +-- +-- "META:" which stores metadata +-- "_\NUL\SOH" 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" + 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") + + 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.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 (L.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-- = +-- map-- = +-- +-- 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" + + 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") + + 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 -> L.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 -> L.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--") + 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 not ("Corruption" `T.isInfixOf` msg) + then throwError ("error opening the database:\n " <> msg) + 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 - configdir <- getXdgDirectory XdgConfig "qutebrowser" - datadir <- getXdgDirectory XdgData "qutebrowser" + configdir <- D.getXdgDirectory D.XdgConfig "qutebrowser" + datadir <- D.getXdgDirectory D.XdgData "qutebrowser" let defaultWhitelist = joinPath [configdir, "whitelists", "cookies"] defaultWebengine = joinPath [datadir, "webengine"] - config <- load [Optional path] - whitelist <- lookupDefault defaultWhitelist config "whitelist-path" - webengine <- lookupDefault defaultWebengine config "webengine-path" - return (Settings whitelist webengine) - - -prettyPrint :: [Text] -> Text -prettyPrint = T.unlines . bullet - where bullet = map (" * " <>) - - -getDirectoryFiles :: FilePath -> IO [FilePath] -getDirectoryFiles path = map (path ) <$> - getDirectoryContents path >>= filterM doesFileExist + config <- C.load [C.Optional path] + 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) -cookies :: Table Cookie -cookies = table "cookies" [] +-- | Catches any Selda error +dbErrors :: S.SeldaError -> Action a +dbErrors e = throwError $ + "database operation failed: " <> T.pack (BE.displayException e) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,38 @@ # Bisc -### A small tool that clears qutebrowser cookies +### 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. + +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. + +## 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 +``` +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. + +Finally, statically compiled binaries can be found in the +[releases](/git/rnhmjoj/bisc/releases). + +[hackage]: http://hackage.haskell.org/package/bisc +[cabal]: https://github.com/haskell/cabal/blob/master/cabal-install/README.md +[stack]: https://docs.haskellstack.org/en/stable/README/ + ## Configuration The bisc configuration file is `$XDG_CONFIG_HOME/bisc/bisc.conf`. @@ -8,8 +40,8 @@ directory and the whitelist file. The default settings are: ``` -whitelist-path = $(XDG_CONFIG_HOME)/qutebrowser/whitelists/cookies -webengine-path = $(XDG_DATA_HOME)/qutebrowser/webengine +whitelist-path = "$(XDG_CONFIG_HOME)/qutebrowser/whitelists/cookies" +webengine-path = "$(XDG_DATA_HOME)/qutebrowser/webengine" ``` ## Usage @@ -24,9 +56,15 @@ 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 +databases (Cookies and QuotaManager) has never happened or been reported to me +and the LevelDB ones (LocalStorage, SessionStorage, IndexedDB), while they do +corrupt more often, are automatically repaired by bisc. + ## License -Copyright (C) 2019 Michele Guerini Rocco +Copyright (C) 2021 Michele Guerini Rocco This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -35,7 +73,7 @@ This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License diff --git a/bisc.cabal b/bisc.cabal --- a/bisc.cabal +++ b/bisc.cabal @@ -1,17 +1,25 @@ name: bisc -version: 0.2.3.0 -synopsis: A small tool that clears qutebrowser cookies. +version: 0.3.0.0 +synopsis: A small tool that clears cookies (and more). description: - Bisc clears qutebrowser cookies and javascript local storage - by domains, stored in a whitelist. + 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. + + homepage: https://maxwell.ydns.eu/git/rnhmjoj/bisc license: GPL-3 license-file: LICENSE author: Michele Guerini Rocco maintainer: rnhmjoj@inventati.org -copyright: Copyright (C) 2019 Michele Guerini Rocco +copyright: Copyright (C) 2021 Michele Guerini Rocco category: Utility build-type: Simple extra-source-files: README.md @@ -25,8 +33,9 @@ main-is: Main.hs build-depends: base ==4.* , selda ==0.*, selda-sqlite ==0.*, + leveldb-haskell ==0.*, filepath, directory, text, - mtl, configurator + mtl, configurator, exceptions, + data-default, bytestring default-language: Haskell2010 - default-extensions: DeriveGeneric, OverloadedStrings - OverloadedLabels, FlexibleContexts + extra-libraries: snappy stdc++