catch all IO exception
This commit is contained in:
parent
9562a20b83
commit
9d8ea96447
57
Main.hs
57
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))
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user