bisc-0.2.0.0: Main.hs

{-# 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.Directory     (removeFile, getDirectoryContents, doesFileExist)
import System.IO            (readFile)

import Database.Selda
import Database.Selda.SQLite

import qualified Data.Text    as T
import qualified Data.Text.IO as T
import qualified System.Environment.XDG.BaseDir as X


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   <- X.getUserConfigFile "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 $ getDirectoryFiles (webengine </> "Application Cache")
  indexedDB    <- liftIO $ getDirectoryFiles (webengine </> "IndexedDB")
  localStorage <- liftIO $ getDirectoryFiles (webengine </> "Local Storage")
  let
    entries    = appCache ++ indexedDB ++ localStorage 
    badFiles   = filterMaybe (fmap unlisted . domain) entries
    badDomains = mapMaybe domain badFiles
  liftIO $ 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)


loadSettings :: FilePath -> IO Settings
loadSettings path = do
  configdir <- X.getUserConfigDir "qutebrowser"
  datadir   <- X.getUserDataDir   "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" []