141 lines
3.9 KiB
Haskell
141 lines
3.9 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# 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.Reader (ReaderT, runReaderT, asks)
|
|
import System.FilePath (joinPath, takeBaseName, (</>))
|
|
import System.IO (readFile)
|
|
import System.Directory
|
|
|
|
import Database.Selda
|
|
import Database.Selda.SQLite
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
|
|
|
|
data Settings = Settings
|
|
{ whitelistPath :: FilePath
|
|
, webenginePath :: FilePath
|
|
}
|
|
|
|
data Cookie = Cookie
|
|
{ host_key :: Text
|
|
, creation_utc :: Int
|
|
} deriving (Generic, Show)
|
|
|
|
instance SqlRow Cookie
|
|
|
|
|
|
type Action = ReaderT Settings IO
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
config <- getXdgDirectory 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.")
|
|
|
|
(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
|
|
|
|
|
|
deleteCookies :: [Text] -> Action (Int, [Text])
|
|
deleteCookies domains = do
|
|
database <- (</> "Cookies") <$> asks webenginePath
|
|
liftIO $ withSQLite database $ do
|
|
bad <- query $ do
|
|
cookie <- select cookies
|
|
restrict (by whitelist cookie)
|
|
return (cookie ! #host_key)
|
|
n <- deleteFrom cookies (by whitelist)
|
|
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
|
|
webengine <- asks webenginePath
|
|
appCache <- liftIO $ listDirectoryAbs (webengine </> "Application Cache")
|
|
indexedDB <- liftIO $ listDirectoryAbs (webengine </> "IndexedDB")
|
|
localStorage <- liftIO $ listDirectoryAbs (webengine </> "Local Storage")
|
|
let
|
|
entries = appCache ++ indexedDB ++ localStorage
|
|
badFiles = filterMaybe (fmap unlisted . domain) entries
|
|
badDomains = mapMaybe domain badFiles
|
|
liftIO $ mapM_ removePathForcibly badFiles
|
|
return (length badFiles, nub badDomains)
|
|
where
|
|
listDirectoryAbs :: FilePath -> IO [FilePath]
|
|
listDirectoryAbs dir = map (dir </>) <$> listDirectory dir
|
|
|
|
maybeToBool :: Maybe Bool -> Bool
|
|
maybeToBool Nothing = False
|
|
maybeToBool (Just x) = x
|
|
|
|
filterMaybe :: (a -> Maybe Bool) -> [a] -> [a]
|
|
filterMaybe f = filter (maybeToBool . f)
|
|
|
|
domain :: FilePath -> Maybe Text
|
|
domain = extract . url where
|
|
extract [] = Nothing
|
|
extract (x:[]) = Nothing
|
|
extract (x:xs) = Just $ T.unwords (init xs)
|
|
url = T.splitOn "_" . T.pack . takeBaseName
|
|
|
|
unlisted = not . (`elem` whitelist)
|
|
|
|
|
|
loadSettings :: FilePath -> IO Settings
|
|
loadSettings path = do
|
|
configdir <- getXdgDirectory XdgConfig "qutebrowser"
|
|
datadir <- getXdgDirectory 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)
|
|
|
|
|
|
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" []
|