implement session storage

Main.hs

@@ -6,6 +6,7 @@
 
 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, (>=>))
@@ -25,6 +26,7 @@ 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
@@ -194,7 +196,9 @@ deleteLocalStorage = do
   when (version /= Just "1") (throwError "Unsupported schema version")
 
   withDB path $ \db ->
-    L.withIterator db def (scanKeys db whitelist)
+    L.withIterator db def $ \iter -> do
+      L.iterFirst iter
+      scanKeys db (by whitelist) iter
 
   where
     -- extract domains from the keys
@@ -203,21 +207,21 @@ deleteLocalStorage = do
     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
+    scanKeys db checker 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 (bad, origin) = checker key
             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
+    by whitelist key
       | "META:" `B.isPrefixOf` key
         && not (metaDomain key `elem` whitelist) = (True, Just (metaDomain key))
       | "_" `B.isPrefixOf` key
@@ -226,6 +230,59 @@ deleteLocalStorage = do
       | otherwise = (False, Nothing)
 
 
+-- | 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"
+
+  version <- withDB path (\db -> L.get db def "version")
+  when (version /= Just "1") (throwError "Unsupported schema version")
+
+  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