implement new local storage

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:<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"
+
+  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

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