diff --git a/Main.hs b/Main.hs index 4d663db..47ef2cb 100644 --- a/Main.hs +++ b/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" [] diff --git a/bisc.cabal b/bisc.cabal index fb495af..aa0e0e3 100644 --- a/bisc.cabal +++ b/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 diff --git a/default.nix b/default.nix index 1516d93..c3dad0e 100644 --- a/default.nix +++ b/default.nix @@ -1,64 +1,33 @@ -{ nixpkgs ? import {} }: +{ nixpkgs ? import {}, 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