implement new local storage
This commit is contained in:
parent
a400ffdc63
commit
8a62391041
GPG Key ID:
BFBAF4C975F76450
189
Main.hs
189
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
|
||||
|
||||
10
bisc.cabal
10
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user