make paths configurable

Main.hs

@@ -3,18 +3,27 @@
 {-# 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 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 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
@@ -23,40 +32,43 @@ data Cookie = Cookie
 
 instance SqlRow Cookie
 
-cookies :: Table Cookie
-cookies = table "cookies" []
+
+type Action = ReaderT Settings IO
 
 
-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"]
+main :: IO ()
+main = do
+  config   <- X.getUserConfigFile "bisc" "bisc.conf"
+  settings <- loadSettings config
+  runReaderT clean settings
 
 
-prettyPrint :: [Text] -> Text
-prettyPrint = T.unlines . bullet
-  where bullet = map ("  * " <>)
+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
 
 
-getDirectoryFiles :: FilePath -> IO [FilePath]
-getDirectoryFiles path = map (path </>) <$>
-  getDirectoryContents path >>= filterM doesFileExist
-
-
-deleteCookies :: [Text] -> IO (Int, [Text])
+deleteCookies :: [Text] -> Action (Int, [Text])
 deleteCookies domains = do
-  database <- databasePath
-  withSQLite database $ do
+  database <- (</> "Cookies") <$> asks webenginePath
+  liftIO $ withSQLite database $ do
     bad <- query $ do
       cookie <- select cookies
       restrict (by whitelist cookie)
@@ -68,13 +80,17 @@ deleteCookies domains = do
     whitelist = map text domains
 
 
-deleteLocalStore :: [Text] -> IO (Int, [Text])
-deleteLocalStore whitelist = do
-  entries <- getDirectoryFiles =<< localStorePath
+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
-  mapM_ removeFile badFiles
+  liftIO $ mapM_ removeFile badFiles
   return (length badFiles, nub badDomains)
   where
     maybeToBool :: Maybe Bool -> Bool
@@ -94,22 +110,29 @@ deleteLocalStore whitelist = do
     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.")
+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"]
 
-  (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.")
+  config    <- load [Optional path]
+  whitelist <- lookupDefault defaultWhitelist config "whitelist-path"
+  webengine <- lookupDefault defaultWebengine config "webengine-path"
+  return (Settings whitelist webengine)
 
-  where log = liftIO . T.putStrLn
-        num = T.pack . show
+
+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" []

bisc.cabal

@@ -18,7 +18,8 @@ executable bisc
   main-is:             Main.hs
   build-depends:       base ==4.* , selda ==0.3.*,
                        selda-sqlite ==0.1.*,
-                       xdg-basedir, filepath, directory, text
+                       xdg-basedir, filepath, directory,
+                       text, mtl, configurator
   default-language:    Haskell2010
   default-extensions:  DeriveGeneric, OverloadedStrings
                        OverloadedLabels, FlexibleContexts

default.nix

@@ -1,64 +1,33 @@
-{ nixpkgs ? import <nixpkgs> {} }:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
 
   inherit (nixpkgs) pkgs;
 
-  haskellPackages = pkgs.haskellPackages.override {
-    overrides = self: super: {
-      selda = self.callPackage
-        ({ mkDerivation, base, bytestring, exceptions, hashable, mtl
-         , psqueues, text, time, unordered-containers
-         }:
-         mkDerivation {
-           pname = "selda";
-           version = "0.3.3.1";
-           sha256 = "1rxwyls59mpmvb5f2l47ak5cnzmws847kgmn8fwbxb69h6a87bwr";
-           enableSharedExecutables = false;
-           libraryHaskellDepends = [
-             base bytestring exceptions hashable mtl psqueues text time
-             unordered-containers
-           ];
-           description = "ulti-backend, high-level EDSL for interacting with SQL databases";
-           license = pkgs.stdenv.lib.licenses.mit;
-           hydraPlatforms = pkgs.stdenv.lib.platforms.none;
-         }) {};
+  f = { mkDerivation, base, configurator, directory, filepath, mtl
+      , selda, selda-sqlite, stdenv, text, xdg-basedir
+      }:
+      mkDerivation {
+        pname = "bisc";
+        version = "0.1.0.0";
+        src = ./.;
+        isLibrary = false;
+        isExecutable = true;
+        executableHaskellDepends = [
+          base configurator directory filepath mtl selda selda-sqlite text
+          xdg-basedir
+        ];
+        description = "A small tool that clears qutebrowser cookies";
+        license = stdenv.lib.licenses.gpl3;
+      };
 
-      selda-sqlite = self.callPackage
-        ({ mkDerivation, base, direct-sqlite, directory, exceptions, text, selda }:
-         mkDerivation {
-           pname = "selda-sqlite";
-           version = "0.1.6.1";
-           sha256 = "1qqrgqzcfwqzlcklm0qjvdy3ndn3zg8s5mp8744v76bd6z2xwq4d";
-           revision = "2";
-           editedCabalFile = "0gb8raqmy8r8xwjpx238mqar5gdfd4194si2ms1a9ndcrilkkqja";
-           libraryHaskellDepends = [
-             base direct-sqlite directory exceptions selda text
-           ];
-           description = "QLite backend for the Selda database EDSL";
-           license = pkgs.stdenv.lib.licenses.mit;
-           hydraPlatforms = pkgs.stdenv.lib.platforms.none;
-         }) {};
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
 
-      bisc = self.callPackage
-        ({ mkDerivation, base, filepath, directory, stdenv, xdg-basedir
-         , selda, selda-sqlite, text }:
-        mkDerivation {
-          pname = "bisc";
-          version = "0.1.0.0";
-          src = ./.;
-          isLibrary = false;
-          isExecutable = true;
-          executableHaskellDepends = [
-            base filepath directory selda selda-sqlite xdg-basedir text
-          ];
-          description = "A small tool that clears qutebrowser cookies";
-          license = stdenv.lib.licenses.gpl3;
-        }) {};
-    };
-  };
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
 
-  drv = haskellPackages.bisc;
+  drv = variant (haskellPackages.callPackage f {});
 
 in