bisc/Main.hs

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

import Data.List            (nub)
import Data.Maybe           (mapMaybe)
import Control.Monad        (mapM_)
import Control.Monad.Reader (ReaderT, runReaderT, asks)
import System.FilePath      (joinPath, takeBaseName, (</>))

import Database.Selda
import Database.Selda.SQLite (withSQLite)

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  -- ^ whitelist file
  , webenginePath :: FilePath  -- ^ webengine data directory
  , whitelist     :: [Text]    -- ^ whitelisted domains
  }


-- SQL records

-- | Just a cookie
data Cookie = Cookie
  { 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


main :: IO ()
main = do
  config   <- D.getXdgDirectory D.XdgConfig ("bisc" </> "bisc.conf")
  settings <- loadSettings config
  runReaderT clean settings


clean :: Action ()
clean = do
  deleteCookies      >>= printResult "Cookies"
  deleteQuotaOrigins >>= printResult "QuotaManager"
  deleteIndexedDB    >>= printResult "IndexedDB"
  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.")


-- | 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
      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)


-- | 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
  unlisted  <- (\domains -> not . (`elem` domains)) <$> asks whitelist
  entries   <- liftIO $ listDirectoryAbs (webengine </> "IndexedDB")
  let
    badFiles   = filterMaybe (fmap unlisted . domain) entries
    badDomains = mapMaybe domain badFiles
  liftIO $ mapM_ D.removePathForcibly badFiles
  return (length badFiles, nub badDomains)
  where
    listDirectoryAbs :: FilePath -> IO [FilePath]
    listDirectoryAbs dir = map (dir </>) <$> D.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


-- | Loads the config from a file
loadSettings :: FilePath -> IO Settings
loadSettings path = do
  configdir <- D.getXdgDirectory D.XdgConfig "qutebrowser"
  datadir   <- D.getXdgDirectory D.XdgData   "qutebrowser"
  let
   defaultWhitelist = joinPath [configdir, "whitelists", "cookies"]
   defaultWebengine = joinPath [datadir, "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

  return (Settings whitelist webengine domains)