bisc/Main.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE FlexibleContexts  #-}

import System.Environment.XDG.BaseDir (getUserDataDir, getUserConfigDir)
import System.FilePath                (joinPath, takeBaseName, (</>))
import System.IO                      (readFile)
import System.Directory               (removeFile, getDirectoryContents, doesFileExist)
import Control.Monad                  (mapM_, filterM)
import Data.List                      (nub)
import Data.Maybe                     (mapMaybe)
import Data.Monoid                    ((<>))
import Database.Selda
import Database.Selda.SQLite
import qualified Data.Text            as T
import qualified Data.Text.IO         as T

data Cookie = Cookie
  { host_key        :: Text
  , creation_utc    :: Int
  } deriving (Generic, Show)

instance SqlRow Cookie

cookies :: Table Cookie
cookies = table "cookies" []


databasePath :: IO FilePath
databasePath = do
  datadir <- getUserDataDir "qutebrowser"
  return $ joinPath [datadir, "webengine", "Cookies"]

localStorePath :: IO FilePath
localStorePath = do
  datadir <- getUserDataDir "qutebrowser"
  return $ joinPath [datadir, "webengine", "Local Storage"]

whitelistPath :: IO FilePath
whitelistPath = do
  configdir <- getUserConfigDir "qutebrowser"
  return $ joinPath [configdir, "whitelists", "cookies"]


prettyPrint :: [Text] -> Text
prettyPrint = T.unlines . bullet
  where bullet = map ("  * " <>)


getDirectoryFiles :: FilePath -> IO [FilePath]
getDirectoryFiles path = map (path </>) <$>
  getDirectoryContents path >>= filterM doesFileExist


deleteCookies :: [Text] -> IO (Int, [Text])
deleteCookies domains = do
  database <- databasePath
  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


deleteLocalStore :: [Text] -> IO (Int, [Text])
deleteLocalStore whitelist = do
  entries <- getDirectoryFiles =<< localStorePath
  let
    badFiles   = filterMaybe (fmap unlisted . domain) entries
    badDomains = mapMaybe domain badFiles
  mapM_ removeFile badFiles
  return (length badFiles, nub badDomains)
  where
    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)


main :: IO ()
main = do
  whitelist <- T.lines <$> (T.readFile =<< whitelistPath)
  (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) <- deleteLocalStore whitelist
  if (n > 0)
    then do
      log ("Local storage: deleted " <> num n <> " entries:")
      log (prettyPrint bad)
    else log ("Local storage: nothing to delete.")

  where log = liftIO . T.putStrLn
        num = T.pack . show