diff --git a/Main.hs b/Main.hs index 62eee1f..ebff981 100644 --- a/Main.hs +++ b/Main.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} import Data.List (nub, foldl') import Data.Maybe (mapMaybe) @@ -20,6 +21,9 @@ import qualified Database.Selda as S import qualified Database.LevelDB as L import qualified Database.LevelDB.Streaming as LS +import Control.Exception as BE +import Control.Monad.Catch as CE + import qualified System.Directory as D import qualified Data.Configurator as C import qualified Data.Text as T @@ -91,16 +95,18 @@ main = do -- | Runs an 'Action' and pretty-prints the results runAction :: Settings -> Text -> Action Result -> IO () runAction settings name x = do - a <- runExceptT (runReaderT x settings) + a <- BE.try $ runExceptT (runReaderT x settings) case a of - Left err -> T.putStrLn (name <> " cleaning failed: " <> err) - Right res -> printResult res + Right (Right res) -> printResult res + Right (Left msg) -> printFailed msg + Left (err :: BE.IOException) -> printFailed (T.pack $ BE.displayException err) where + printFailed msg = T.putStrLn ("- " <> name <> " cleaning failed:\n " <> msg) printResult (n, bad) | n > 0 = do - T.putStrLn (name <> ": deleted " <> T.pack (show n) <> " entries for:") + T.putStrLn ("- " <> name <> ": deleted " <> T.pack (show n) <> " entries for:") T.putStrLn (T.unlines $ map (" * " <>) bad) - | otherwise = T.putStrLn (name <> ": nothing to delete.") + | otherwise = T.putStrLn ("- " <> name <> ": nothing to delete") -- * Cleaning actions @@ -109,8 +115,11 @@ runAction settings name x = do deleteCookies :: Action Result deleteCookies = do database <- ( "Cookies") <$> asks webenginePath + exists <- liftIO $ D.doesFileExist database + when (not exists) (throwError "database is missing") + whitelist <- map S.text <$> asks whitelist - withSQLite database $ do + CE.handle dbErrors $ withSQLite database $ do bad <- S.query $ do cookie <- S.select cookies S.restrict (by whitelist cookie) @@ -125,8 +134,11 @@ deleteCookies = do deleteQuotaOrigins :: Action Result deleteQuotaOrigins = do database <- ( "QuotaManager") <$> asks webenginePath + exists <- liftIO $ D.doesFileExist database + when (not exists) (throwError "database is missing") + whitelist <- map pattern <$> asks whitelist - withSQLite database $ do + CE.handle dbErrors $ withSQLite database $ do bad <- S.query $ do quota <- S.select quotaOrigins S.restrict (by whitelist quota) @@ -151,16 +163,19 @@ deleteQuotaOrigins = do deleteIndexedDB :: Action Result deleteIndexedDB = do webengine <- asks webenginePath + exists <- liftIO $ D.doesDirectoryExist (webengine "IndexedDB") + when (not exists) $ throwError "directory is missing" + + entries <- listDirectoryAbs (webengine "IndexedDB") 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 + listDirectoryAbs :: FilePath -> Action [FilePath] + listDirectoryAbs dir = liftIO $ map (dir ) <$> D.listDirectory dir maybeToBool :: Maybe Bool -> Bool maybeToBool Nothing = False @@ -193,10 +208,10 @@ deleteLocalStorage = do let path = webengine "Local Storage" "leveldb" dbIsOk <- liftIO $ D.doesFileExist (path "LOCK") - when (not dbIsOk) (throwError "Database is missing or corrupted") + when (not dbIsOk) (throwError "database is missing or corrupted") version <- withDB path (\db -> L.get db def "VERSION") - when (version /= Just "1") (throwError "Database is empty or the schema unsupported") + when (version /= Just "1") (throwError "database is empty or the schema unsupported") withDB path $ \db -> do badDomains <- L.withIterator db def $ \i -> @@ -238,10 +253,10 @@ deleteSessionStorage = do let path = webengine "Session Storage" dbIsOk <- liftIO $ D.doesFileExist (path "LOCK") - when (not dbIsOk) (throwError "Database is missing or corrupted") + when (not dbIsOk) (throwError "database is missing or corrupted") version <- withDB path (\db -> L.get db def "version") - when (version /= Just "1") (throwError "Database is empty or the schema unsupported") + when (version /= Just "1") (throwError "database is empty or the schema unsupported") withDB path $ \db -> do -- map of id -> isBad @@ -300,3 +315,7 @@ loadSettings path = do domains <- T.lines <$> T.readFile whitelist return (Settings whitelist webengine domains) + +-- | Catches any Selda error +dbErrors :: S.SeldaError -> Action a +dbErrors e = throwError ("database operation failed: " <> T.pack (show e)) diff --git a/bisc.cabal b/bisc.cabal index d588cb5..58a33b3 100644 --- a/bisc.cabal +++ b/bisc.cabal @@ -35,6 +35,6 @@ executable bisc selda-sqlite ==0.*, leveldb-haskell ==0.*, filepath, directory, text, - mtl, configurator, + mtl, configurator, exceptions, data-default, bytestring default-language: Haskell2010