bisc 0.2.3.0 → 0.3.0.0
raw patch · 3 files changed
+337/−95 lines, 3 filesdep +bytestringdep +data-defaultdep +exceptions
Dependencies added: bytestring, data-default, exceptions, leveldb-haskell
Files
- Main.hs +277/−82
- README.md +43/−5
- bisc.cabal +17/−8
Main.hs view
@@ -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:<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" + 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-<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"++ 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-<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 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)
README.md view
@@ -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
bisc.cabal view
@@ -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++