general cleanup
This commit is contained in:
parent
ee51a8493f
commit
a400ffdc63
GPG Key ID:
BFBAF4C975F76450
155
Main.hs
155
Main.hs
@ -1,35 +1,59 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
import Data.List (nub)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Configurator
|
||||
import Control.Monad (mapM_, filterM)
|
||||
import Control.Monad (mapM_)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT, asks)
|
||||
import System.FilePath (joinPath, takeBaseName, (</>))
|
||||
import System.IO (readFile)
|
||||
import System.Directory
|
||||
|
||||
import Database.Selda
|
||||
import Database.Selda.SQLite
|
||||
import Database.Selda.SQLite (withSQLite)
|
||||
|
||||
import qualified Data.Text as T
|
||||
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
|
||||
|
||||
|
||||
-- | Bisc settings
|
||||
data Settings = Settings
|
||||
{ whitelistPath :: FilePath
|
||||
, webenginePath :: FilePath
|
||||
{ whitelistPath :: FilePath -- ^ whitelist file
|
||||
, webenginePath :: FilePath -- ^ webengine data directory
|
||||
, whitelist :: [Text] -- ^ whitelisted domains
|
||||
}
|
||||
|
||||
|
||||
-- SQL records
|
||||
|
||||
-- | Just a cookie
|
||||
data Cookie = Cookie
|
||||
{ host_key :: Text
|
||||
, creation_utc :: Int
|
||||
{ host_key :: Text -- ^ cookie domain
|
||||
, creation_utc :: Int -- ^ creation date
|
||||
} deriving (Generic, Show)
|
||||
|
||||
-- | The origin (domain) of a quota
|
||||
data QuotaOrigin = QuotaOrigin
|
||||
{ origin :: Text -- ^ URL
|
||||
, last_modified_time :: Int -- ^ creation date
|
||||
} deriving (Generic, Show)
|
||||
|
||||
instance SqlRow Cookie
|
||||
instance SqlRow QuotaOrigin
|
||||
|
||||
|
||||
-- SQL tables
|
||||
|
||||
-- | Cookies table
|
||||
cookies :: Table Cookie
|
||||
cookies = table "cookies" []
|
||||
|
||||
-- | QuotaManager origins table
|
||||
quotaOrigins :: Table QuotaOrigin
|
||||
quotaOrigins = table "OriginInfoTable" []
|
||||
|
||||
|
||||
type Action = ReaderT Settings IO
|
||||
@ -37,36 +61,33 @@ type Action = ReaderT Settings IO
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
config <- getXdgDirectory XdgConfig ("bisc" </> "bisc.conf")
|
||||
config <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
|
||||
settings <- loadSettings config
|
||||
runReaderT clean settings
|
||||
|
||||
|
||||
clean :: Action ()
|
||||
clean = do
|
||||
path <- asks whitelistPath
|
||||
whitelist <- liftIO (T.lines <$> T.readFile path)
|
||||
(n, bad) <- deleteCookies whitelist
|
||||
if (n > 0)
|
||||
then do
|
||||
log ("Cookies: deleted " <> num n <> " from:")
|
||||
log (prettyPrint bad)
|
||||
else log ("Cookies: nothing to delete.")
|
||||
deleteCookies >>= printResult "Cookies"
|
||||
deleteQuotaOrigins >>= printResult "QuotaManager"
|
||||
deleteIndexedDB >>= printResult "IndexedDB"
|
||||
where
|
||||
log = liftIO . T.putStrLn
|
||||
num = T.pack . show
|
||||
|
||||
(n, bad) <- deleteData whitelist
|
||||
if (n > 0)
|
||||
then do
|
||||
log ("Persistent data: deleted " <> num n <> " entries:")
|
||||
log (prettyPrint bad)
|
||||
else log ("Persistent data: nothing to delete.")
|
||||
|
||||
where log = liftIO . T.putStrLn
|
||||
num = T.pack . show
|
||||
printResult :: Text -> (Int, [Text]) -> Action ()
|
||||
printResult name (n, bad)
|
||||
| n > 0 = do
|
||||
log $ name <> ": deleted " <> num n <> " entries:"
|
||||
log $ T.unlines (map (" * " <>) bad)
|
||||
| otherwise = log (name <> ": nothing to delete.")
|
||||
|
||||
|
||||
deleteCookies :: [Text] -> Action (Int, [Text])
|
||||
deleteCookies domains = do
|
||||
database <- (</> "Cookies") <$> asks webenginePath
|
||||
-- | Deletes records in the Cookies database
|
||||
deleteCookies :: Action (Int, [Text])
|
||||
deleteCookies = do
|
||||
database <- (</> "Cookies") <$> asks webenginePath
|
||||
whitelist <- map text <$> asks whitelist
|
||||
liftIO $ withSQLite database $ do
|
||||
bad <- query $ do
|
||||
cookie <- select cookies
|
||||
@ -76,24 +97,47 @@ deleteCookies domains = do
|
||||
return (n, nub bad)
|
||||
where
|
||||
by set x = not_ (x ! #host_key `isIn` set)
|
||||
whitelist = map text domains
|
||||
|
||||
|
||||
deleteData :: [Text] -> Action (Int, [Text])
|
||||
deleteData whitelist = do
|
||||
-- | Deletes records in the QuotaManager API database
|
||||
deleteQuotaOrigins :: Action (Int, [Text])
|
||||
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)
|
||||
return (quota ! #origin)
|
||||
n <- 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
|
||||
-- turns domains into patterns to match a url
|
||||
pattern domain = text ("http%://%"<>domain<>"/")
|
||||
|
||||
|
||||
-- | Deletes per-domain files under the IndexedDB directory
|
||||
--
|
||||
-- For example:
|
||||
--
|
||||
-- https_example.com_0.indexeddb.leveldb
|
||||
-- https_www.example.com_0.indexeddb.leveldb
|
||||
--
|
||||
deleteIndexedDB :: Action (Int, [Text])
|
||||
deleteIndexedDB = do
|
||||
webengine <- asks webenginePath
|
||||
appCache <- liftIO $ listDirectoryAbs (webengine </> "Application Cache")
|
||||
indexedDB <- liftIO $ listDirectoryAbs (webengine </> "IndexedDB")
|
||||
localStorage <- liftIO $ listDirectoryAbs (webengine </> "Local Storage")
|
||||
unlisted <- (\domains -> not . (`elem` domains)) <$> asks whitelist
|
||||
entries <- liftIO $ listDirectoryAbs (webengine </> "IndexedDB")
|
||||
let
|
||||
entries = appCache ++ indexedDB ++ localStorage
|
||||
badFiles = filterMaybe (fmap unlisted . domain) entries
|
||||
badDomains = mapMaybe domain badFiles
|
||||
liftIO $ mapM_ removePathForcibly badFiles
|
||||
liftIO $ mapM_ D.removePathForcibly badFiles
|
||||
return (length badFiles, nub badDomains)
|
||||
where
|
||||
listDirectoryAbs :: FilePath -> IO [FilePath]
|
||||
listDirectoryAbs dir = map (dir </>) <$> listDirectory dir
|
||||
listDirectoryAbs dir = map (dir </>) <$> D.listDirectory dir
|
||||
|
||||
maybeToBool :: Maybe Bool -> Bool
|
||||
maybeToBool Nothing = False
|
||||
@ -109,32 +153,19 @@ deleteData whitelist = do
|
||||
extract (x:xs) = Just $ T.unwords (init xs)
|
||||
url = T.splitOn "_" . T.pack . takeBaseName
|
||||
|
||||
unlisted = not . (`elem` whitelist)
|
||||
|
||||
|
||||
-- | Loads the config from a file
|
||||
loadSettings :: FilePath -> IO Settings
|
||||
loadSettings path = do
|
||||
configdir <- getXdgDirectory XdgConfig "qutebrowser"
|
||||
datadir <- getXdgDirectory XdgData "qutebrowser"
|
||||
configdir <- D.getXdgDirectory D.XdgConfig "qutebrowser"
|
||||
datadir <- D.getXdgDirectory D.XdgData "qutebrowser"
|
||||
let
|
||||
defaultWhitelist = joinPath [configdir, "whitelists", "cookies"]
|
||||
defaultWebengine = joinPath [datadir, "webengine"]
|
||||
|
||||
config <- load [Optional path]
|
||||
whitelist <- lookupDefault defaultWhitelist config "whitelist-path"
|
||||
webengine <- lookupDefault defaultWebengine config "webengine-path"
|
||||
return (Settings whitelist webengine)
|
||||
config <- C.load [C.Optional path]
|
||||
whitelist <- C.lookupDefault defaultWhitelist config "whitelist-path"
|
||||
webengine <- C.lookupDefault defaultWebengine config "webengine-path"
|
||||
domains <- T.lines <$> T.readFile whitelist
|
||||
|
||||
|
||||
prettyPrint :: [Text] -> Text
|
||||
prettyPrint = T.unlines . bullet
|
||||
where bullet = map (" * " <>)
|
||||
|
||||
|
||||
getDirectoryFiles :: FilePath -> IO [FilePath]
|
||||
getDirectoryFiles path = map (path </>) <$>
|
||||
getDirectoryContents path >>= filterM doesFileExist
|
||||
|
||||
|
||||
cookies :: Table Cookie
|
||||
cookies = table "cookies" []
|
||||
return (Settings whitelist webengine domains)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user