From 8a62391041665e3603ff09a839d0dc29967960af Mon Sep 17 00:00:00 2001 From: rnhmjoj Date: Tue, 23 Mar 2021 16:09:03 +0100 Subject: [PATCH] implement new local storage --- Main.hs | 189 +++++++++++++++++++++++++++++++++++++---------------- bisc.cabal | 10 +-- 2 files changed, 139 insertions(+), 60 deletions(-) diff --git a/Main.hs b/Main.hs index 7e87751..982169e 100644 --- a/Main.hs +++ b/Main.hs @@ -4,19 +4,26 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE FlexibleContexts #-} -import Data.List (nub) -import Data.Maybe (mapMaybe) -import Control.Monad (mapM_) -import Control.Monad.Reader (ReaderT, runReaderT, asks) -import System.FilePath (joinPath, takeBaseName, ()) - -import Database.Selda +import Data.List (nub, foldl') +import Data.Maybe (mapMaybe) +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 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 Database.Selda as S +import qualified Database.LevelDB as L +import qualified Database.LevelDB.Streaming as LS + +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 -- | Bisc settings @@ -33,89 +40,103 @@ data Settings = Settings data Cookie = Cookie { host_key :: Text -- ^ cookie domain , creation_utc :: Int -- ^ creation date - } deriving (Generic, Show) + } deriving (S.Generic, Show) -- | The origin (domain) of a quota data QuotaOrigin = QuotaOrigin { origin :: Text -- ^ URL , last_modified_time :: Int -- ^ creation date - } deriving (Generic, Show) + } deriving (S.Generic, Show) -instance SqlRow Cookie -instance SqlRow QuotaOrigin +instance S.SqlRow Cookie +instance S.SqlRow QuotaOrigin -- SQL tables -- | Cookies table -cookies :: Table Cookie -cookies = table "cookies" [] +cookies :: S.Table Cookie +cookies = S.table "cookies" [] -- | QuotaManager origins table -quotaOrigins :: Table QuotaOrigin -quotaOrigins = table "OriginInfoTable" [] +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]) -type Action = ReaderT Settings IO - +-- * Main +-- | Clears all means of permanent storage main :: IO () main = do - config <- D.getXdgDirectory D.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 - deleteCookies >>= printResult "Cookies" - deleteQuotaOrigins >>= printResult "QuotaManager" - deleteIndexedDB >>= printResult "IndexedDB" +-- | Runs an 'Action' and pretty-prints the results +runAction :: Settings -> Text -> Action Result -> IO () +runAction settings name x = do + a <- runExceptT (runReaderT x settings) + case a of + Left err -> T.putStrLn (name <> " cleaning failed: " <> err) + Right res -> printResult res where - log = liftIO . T.putStrLn - num = T.pack . show - - printResult :: Text -> (Int, [Text]) -> Action () - printResult name (n, bad) + printResult (n, bad) | n > 0 = do - log $ name <> ": deleted " <> num n <> " entries:" - log $ T.unlines (map (" * " <>) bad) - | otherwise = log (name <> ": nothing to delete.") + T.putStrLn (name <> ": deleted " <> T.pack (show n) <> " entries for:") + T.putStrLn (T.unlines $ map (" * " <>) bad) + | otherwise = T.putStrLn (name <> ": nothing to delete.") +-- * Cleaning actions + -- | Deletes records in the Cookies database -deleteCookies :: Action (Int, [Text]) +deleteCookies :: Action Result deleteCookies = do database <- ( "Cookies") <$> asks webenginePath - whitelist <- map text <$> asks whitelist - liftIO $ withSQLite database $ do - bad <- query $ do - cookie <- select cookies - restrict (by whitelist cookie) + whitelist <- map S.text <$> asks whitelist + 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) + by set x = S.not_ (x ! #host_key `S.isIn` set) -- | Deletes records in the QuotaManager API database -deleteQuotaOrigins :: Action (Int, [Text]) +deleteQuotaOrigins :: Action Result deleteQuotaOrigins = do database <- ( "QuotaManager") <$> asks webenginePath whitelist <- map pattern <$> asks whitelist - liftIO $ withSQLite database $ do - bad <- query $ do - quota <- select quotaOrigins - restrict (by whitelist quota) + withSQLite database $ do + bad <- S.query $ do + quota <- S.select quotaOrigins + S.restrict (by whitelist quota) return (quota ! #origin) - n <- deleteFrom quotaOrigins (by whitelist) + n <- S.deleteFrom quotaOrigins (by whitelist) return (n, nub bad) where - -- basically not (any (`like` x ! #origin) set) - by set x = not_ $ foldl1 (.||) $ map (`like` x ! #origin) set + -- 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 = text ("http%://%"<>domain<>"/") + pattern domain = S.text ("http%://%" <> domain <> "/") + any_ = foldl' (.||) S.false -- | Deletes per-domain files under the IndexedDB directory @@ -125,7 +146,7 @@ deleteQuotaOrigins = do -- https_example.com_0.indexeddb.leveldb -- https_www.example.com_0.indexeddb.leveldb -- -deleteIndexedDB :: Action (Int, [Text]) +deleteIndexedDB :: Action Result deleteIndexedDB = do webengine <- asks webenginePath unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist @@ -154,6 +175,64 @@ deleteIndexedDB = do 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:" 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" + + version <- withDB path (\db -> L.get db def "VERSION") + when (version /= Just "1") (throwError "Unsupported schema version") + + withDB path $ \db -> + L.withIterator db def (scanKeys db whitelist) + + 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 + + -- scan the database and delete keys from unlisted domain + scanKeys db whitelist i = L.iterFirst i >> go 0 [] where + go n domains = do + mkey <- L.iterKey i + case mkey of + -- end of database + Nothing -> return (n, domains) + Just key -> do + let (bad, origin) = isBad key whitelist + let m = if bad then n+1 else n + when bad (L.delete db def key) + L.iterNext i + go m (maybe domains (:domains) origin) + + -- check if unlisted and return the domain if a meta record + isBad key whitelist + | "META:" `B.isPrefixOf` key + && not (metaDomain key `elem` whitelist) = (True, Just (metaDomain key)) + | "_" `B.isPrefixOf` key + && "\NUL\SOH" `B.isInfixOf` key + && not (recDomain key `elem` whitelist) = (True, Nothing) + | otherwise = (False, Nothing) + + +-- * 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) + -- | Loads the config from a file loadSettings :: FilePath -> IO Settings loadSettings path = do diff --git a/bisc.cabal b/bisc.cabal index 48f696f..3c11376 100644 --- a/bisc.cabal +++ b/bisc.cabal @@ -1,5 +1,5 @@ name: bisc -version: 0.2.3.0 +version: 0.2.4.0 synopsis: A small tool that clears qutebrowser cookies. description: @@ -11,7 +11,7 @@ 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 +25,8 @@ executable bisc main-is: Main.hs build-depends: base ==4.* , selda ==0.*, selda-sqlite ==0.*, + leveldb-haskell ==0.*, filepath, directory, text, - mtl, configurator + mtl, configurator, + data-default, bytestring default-language: Haskell2010 - default-extensions: DeriveGeneric, OverloadedStrings - OverloadedLabels, FlexibleContexts