diff --git a/Main.hs b/Main.hs index ec88a56..7e87751 100644 --- a/Main.hs +++ b/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)