catch all IO exception

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))

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