implement new local storage
This commit is contained in:
parent
a400ffdc63
commit
8a62391041
189
Main.hs
189
Main.hs
@ -4,19 +4,26 @@
|
|||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
import Data.List (nub)
|
import Data.List (nub, foldl')
|
||||||
import Data.Maybe (mapMaybe)
|
import Data.Maybe (mapMaybe)
|
||||||
import Control.Monad (mapM_)
|
import Data.Default (def)
|
||||||
import Control.Monad.Reader (ReaderT, runReaderT, asks)
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
import System.FilePath (joinPath, takeBaseName, (</>))
|
import Control.Monad (mapM_, when, (>=>))
|
||||||
|
import Control.Monad.Reader (ReaderT, runReaderT, asks)
|
||||||
import Database.Selda
|
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.SQLite (withSQLite)
|
||||||
|
|
||||||
import qualified System.Directory as D
|
import qualified Database.Selda as S
|
||||||
import qualified Data.Configurator as C
|
import qualified Database.LevelDB as L
|
||||||
import qualified Data.Text as T
|
import qualified Database.LevelDB.Streaming as LS
|
||||||
import qualified Data.Text.IO as T
|
|
||||||
|
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
|
-- | Bisc settings
|
||||||
@ -33,89 +40,103 @@ data Settings = Settings
|
|||||||
data Cookie = Cookie
|
data Cookie = Cookie
|
||||||
{ host_key :: Text -- ^ cookie domain
|
{ host_key :: Text -- ^ cookie domain
|
||||||
, creation_utc :: Int -- ^ creation date
|
, creation_utc :: Int -- ^ creation date
|
||||||
} deriving (Generic, Show)
|
} deriving (S.Generic, Show)
|
||||||
|
|
||||||
-- | The origin (domain) of a quota
|
-- | The origin (domain) of a quota
|
||||||
data QuotaOrigin = QuotaOrigin
|
data QuotaOrigin = QuotaOrigin
|
||||||
{ origin :: Text -- ^ URL
|
{ origin :: Text -- ^ URL
|
||||||
, last_modified_time :: Int -- ^ creation date
|
, last_modified_time :: Int -- ^ creation date
|
||||||
} deriving (Generic, Show)
|
} deriving (S.Generic, Show)
|
||||||
|
|
||||||
instance SqlRow Cookie
|
instance S.SqlRow Cookie
|
||||||
instance SqlRow QuotaOrigin
|
instance S.SqlRow QuotaOrigin
|
||||||
|
|
||||||
|
|
||||||
-- SQL tables
|
-- SQL tables
|
||||||
|
|
||||||
-- | Cookies table
|
-- | Cookies table
|
||||||
cookies :: Table Cookie
|
cookies :: S.Table Cookie
|
||||||
cookies = table "cookies" []
|
cookies = S.table "cookies" []
|
||||||
|
|
||||||
-- | QuotaManager origins table
|
-- | QuotaManager origins table
|
||||||
quotaOrigins :: Table QuotaOrigin
|
quotaOrigins :: S.Table QuotaOrigin
|
||||||
quotaOrigins = table "OriginInfoTable" []
|
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 :: IO ()
|
||||||
main = do
|
main = do
|
||||||
config <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
|
config <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
|
||||||
settings <- loadSettings config
|
run <- runAction <$> loadSettings config
|
||||||
runReaderT clean settings
|
run "Cookies" deleteCookies
|
||||||
|
run "QuotaManager" deleteQuotaOrigins
|
||||||
|
run "IndexedDB" deleteIndexedDB
|
||||||
|
run "LocalStorage" deleteLocalStorage
|
||||||
|
run "SessionStorage" deleteSessionStorage
|
||||||
|
|
||||||
|
|
||||||
clean :: Action ()
|
-- | Runs an 'Action' and pretty-prints the results
|
||||||
clean = do
|
runAction :: Settings -> Text -> Action Result -> IO ()
|
||||||
deleteCookies >>= printResult "Cookies"
|
runAction settings name x = do
|
||||||
deleteQuotaOrigins >>= printResult "QuotaManager"
|
a <- runExceptT (runReaderT x settings)
|
||||||
deleteIndexedDB >>= printResult "IndexedDB"
|
case a of
|
||||||
|
Left err -> T.putStrLn (name <> " cleaning failed: " <> err)
|
||||||
|
Right res -> printResult res
|
||||||
where
|
where
|
||||||
log = liftIO . T.putStrLn
|
printResult (n, bad)
|
||||||
num = T.pack . show
|
|
||||||
|
|
||||||
printResult :: Text -> (Int, [Text]) -> Action ()
|
|
||||||
printResult name (n, bad)
|
|
||||||
| n > 0 = do
|
| n > 0 = do
|
||||||
log $ name <> ": deleted " <> num n <> " entries:"
|
T.putStrLn (name <> ": deleted " <> T.pack (show n) <> " entries for:")
|
||||||
log $ T.unlines (map (" * " <>) bad)
|
T.putStrLn (T.unlines $ map (" * " <>) bad)
|
||||||
| otherwise = log (name <> ": nothing to delete.")
|
| otherwise = T.putStrLn (name <> ": nothing to delete.")
|
||||||
|
|
||||||
|
|
||||||
|
-- * Cleaning actions
|
||||||
|
|
||||||
-- | Deletes records in the Cookies database
|
-- | Deletes records in the Cookies database
|
||||||
deleteCookies :: Action (Int, [Text])
|
deleteCookies :: Action Result
|
||||||
deleteCookies = do
|
deleteCookies = do
|
||||||
database <- (</> "Cookies") <$> asks webenginePath
|
database <- (</> "Cookies") <$> asks webenginePath
|
||||||
whitelist <- map text <$> asks whitelist
|
whitelist <- map S.text <$> asks whitelist
|
||||||
liftIO $ withSQLite database $ do
|
withSQLite database $ do
|
||||||
bad <- query $ do
|
bad <- S.query $ do
|
||||||
cookie <- select cookies
|
cookie <- S.select cookies
|
||||||
restrict (by whitelist cookie)
|
S.restrict (by whitelist cookie)
|
||||||
return (cookie ! #host_key)
|
return (cookie ! #host_key)
|
||||||
n <- deleteFrom cookies (by whitelist)
|
n <- S.deleteFrom cookies (by whitelist)
|
||||||
return (n, nub bad)
|
return (n, nub bad)
|
||||||
where
|
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
|
-- | Deletes records in the QuotaManager API database
|
||||||
deleteQuotaOrigins :: Action (Int, [Text])
|
deleteQuotaOrigins :: Action Result
|
||||||
deleteQuotaOrigins = do
|
deleteQuotaOrigins = do
|
||||||
database <- (</> "QuotaManager") <$> asks webenginePath
|
database <- (</> "QuotaManager") <$> asks webenginePath
|
||||||
whitelist <- map pattern <$> asks whitelist
|
whitelist <- map pattern <$> asks whitelist
|
||||||
liftIO $ withSQLite database $ do
|
withSQLite database $ do
|
||||||
bad <- query $ do
|
bad <- S.query $ do
|
||||||
quota <- select quotaOrigins
|
quota <- S.select quotaOrigins
|
||||||
restrict (by whitelist quota)
|
S.restrict (by whitelist quota)
|
||||||
return (quota ! #origin)
|
return (quota ! #origin)
|
||||||
n <- deleteFrom quotaOrigins (by whitelist)
|
n <- S.deleteFrom quotaOrigins (by whitelist)
|
||||||
return (n, nub bad)
|
return (n, nub bad)
|
||||||
where
|
where
|
||||||
-- basically not (any (`like` x ! #origin) set)
|
-- check if x ∉ set
|
||||||
by set x = not_ $ foldl1 (.||) $ map (`like` x ! #origin) set
|
by set x = S.not_ . any_ . map (S.like (x ! #origin)) $ set
|
||||||
-- turns domains into patterns to match a url
|
-- 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
|
-- | Deletes per-domain files under the IndexedDB directory
|
||||||
@ -125,7 +146,7 @@ deleteQuotaOrigins = do
|
|||||||
-- https_example.com_0.indexeddb.leveldb
|
-- https_example.com_0.indexeddb.leveldb
|
||||||
-- https_www.example.com_0.indexeddb.leveldb
|
-- https_www.example.com_0.indexeddb.leveldb
|
||||||
--
|
--
|
||||||
deleteIndexedDB :: Action (Int, [Text])
|
deleteIndexedDB :: Action Result
|
||||||
deleteIndexedDB = do
|
deleteIndexedDB = do
|
||||||
webengine <- asks webenginePath
|
webengine <- asks webenginePath
|
||||||
unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist
|
unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist
|
||||||
@ -154,6 +175,64 @@ deleteIndexedDB = do
|
|||||||
url = T.splitOn "_" . T.pack . takeBaseName
|
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
|
-- | Loads the config from a file
|
||||||
loadSettings :: FilePath -> IO Settings
|
loadSettings :: FilePath -> IO Settings
|
||||||
loadSettings path = do
|
loadSettings path = do
|
||||||
|
10
bisc.cabal
10
bisc.cabal
@ -1,5 +1,5 @@
|
|||||||
name: bisc
|
name: bisc
|
||||||
version: 0.2.3.0
|
version: 0.2.4.0
|
||||||
synopsis: A small tool that clears qutebrowser cookies.
|
synopsis: A small tool that clears qutebrowser cookies.
|
||||||
description:
|
description:
|
||||||
|
|
||||||
@ -11,7 +11,7 @@ license: GPL-3
|
|||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michele Guerini Rocco
|
author: Michele Guerini Rocco
|
||||||
maintainer: rnhmjoj@inventati.org
|
maintainer: rnhmjoj@inventati.org
|
||||||
copyright: Copyright (C) 2019 Michele Guerini Rocco
|
copyright: Copyright (C) 2021 Michele Guerini Rocco
|
||||||
category: Utility
|
category: Utility
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files: README.md
|
extra-source-files: README.md
|
||||||
@ -25,8 +25,8 @@ executable bisc
|
|||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends: base ==4.* , selda ==0.*,
|
build-depends: base ==4.* , selda ==0.*,
|
||||||
selda-sqlite ==0.*,
|
selda-sqlite ==0.*,
|
||||||
|
leveldb-haskell ==0.*,
|
||||||
filepath, directory, text,
|
filepath, directory, text,
|
||||||
mtl, configurator
|
mtl, configurator,
|
||||||
|
data-default, bytestring
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: DeriveGeneric, OverloadedStrings
|
|
||||||
OverloadedLabels, FlexibleContexts
|
|
||||||
|
Loading…
Reference in New Issue
Block a user