general cleanup

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_)
-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 Database.Selda.SQLite (withSQLite)
 
-import qualified Data.Text        as T
+import qualified System.Directory   as D
-import qualified Data.Text.IO     as T
+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
+  { whitelistPath :: FilePath  -- ^ whitelist file
-  , webenginePath :: FilePath
+  , webenginePath :: FilePath  -- ^ webengine data directory
+  , whitelist     :: [Text]    -- ^ whitelisted domains
   }
 
+
+-- SQL records
+
+-- | Just a cookie
 data Cookie = Cookie
-  { host_key        :: Text
+  { host_key     :: Text  -- ^ cookie domain
-  , creation_utc    :: Int
+  , 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
+  deleteCookies      >>= printResult "Cookies"
-  whitelist <- liftIO (T.lines <$> T.readFile path)
+  deleteQuotaOrigins >>= printResult "QuotaManager"
-  (n, bad)  <- deleteCookies whitelist
+  deleteIndexedDB    >>= printResult "IndexedDB"
-  if (n > 0)
+  where
-    then do
+    log = liftIO . T.putStrLn
-      log ("Cookies: deleted " <> num n <> " from:")
+    num = T.pack . show
-      log (prettyPrint bad)
-    else log ("Cookies: nothing to delete.")
 
-  (n, bad) <- deleteData whitelist
+    printResult :: Text -> (Int, [Text]) -> Action ()
-  if (n > 0)
+    printResult name (n, bad)
-    then do
+      | n > 0 = do
-      log ("Persistent data: deleted " <> num n <> " entries:")
+        log $ name <> ": deleted " <> num n <> " entries:"
-      log (prettyPrint bad)
+        log $ T.unlines (map ("  * " <>) bad)
-    else log ("Persistent data: nothing to delete.")
+      | otherwise = log (name <> ": nothing to delete.")
-
-  where log = liftIO . T.putStrLn
-        num = T.pack . show
 
 
-deleteCookies :: [Text] -> Action (Int, [Text])
+-- | Deletes records in the Cookies database
-deleteCookies domains = do
+deleteCookies :: Action (Int, [Text])
-  database <- (</> "Cookies") <$> asks webenginePath
+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])
+-- | Deletes records in the QuotaManager API database
-deleteData whitelist = do
+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")
+  unlisted  <- (\domains -> not . (`elem` domains)) <$> asks whitelist
-  indexedDB    <- liftIO $ listDirectoryAbs (webengine </> "IndexedDB")
+  entries   <- 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
+  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"
+  configdir <- D.getXdgDirectory D.XdgConfig "qutebrowser"
-  datadir   <- getXdgDirectory XdgData   "qutebrowser"
+  datadir   <- D.getXdgDirectory D.XdgData   "qutebrowser"
   let
    defaultWhitelist = joinPath [configdir, "whitelists", "cookies"]
    defaultWebengine = joinPath [datadir, "webengine"]
 
-  config    <- load [Optional path]
+  config    <- C.load [C.Optional path]
-  whitelist <- lookupDefault defaultWhitelist config "whitelist-path"
+  whitelist <- C.lookupDefault defaultWhitelist config "whitelist-path"
-  webengine <- lookupDefault defaultWebengine config "webengine-path"
+  webengine <- C.lookupDefault defaultWebengine config "webengine-path"
-  return (Settings whitelist webengine)
+  domains   <- T.lines <$> T.readFile whitelist
 
-
+  return (Settings whitelist webengine domains)
-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" []