fix some warnings

Main.hs

@@ -7,8 +7,9 @@
 {-# LANGUAGE MultiWayIf          #-}
 
 -- Databases
-import Database.Selda        (Text, liftIO, (!))
-import Database.Selda.SQLite (withSQLite)
+import Database.Selda               (Text, liftIO, (!))
+import Database.Selda.SQLite        (withSQLite)
+import Control.Monad.Trans.Resource (ResourceT)
 import qualified Database.Selda             as S
 import qualified Database.LevelDB           as L
 import qualified Database.LevelDB.Streaming as LS
@@ -200,18 +201,13 @@ deleteCookies :: Action Result
 deleteCookies = do
   dir <- asks webenginePath
   dry <- asks (dryRun . options)
-  unsafe <- asks (unsafe . options)
 
-  let
-    database = dir </> "Cookies"
-    context  = if unsafe then bypassLocks "Cookies"
-                         else ($ database)
-
-  exists <- liftIO $ D.doesFileExist database
+  -- check for database
+  exists <- liftIO $ D.doesFileExist (dir </> "Cookies")
   when (not exists) (throwError "database is missing")
 
   whitelist <- map S.text <$> asks whitelist
-  context $ \database -> do
+  withoutLocks "Cookies" $ \database -> do
     CE.handle dbErrors $ withSQLite database $ do
       bad <- S.query $ do
         cookie <- S.select cookies
@@ -229,18 +225,13 @@ deleteQuotaOrigins :: Action Result
 deleteQuotaOrigins = do
   dir <- asks webenginePath
   dry <- asks (dryRun . options)
-  unsafe <- asks (unsafe . options)
 
-  let
-    database = dir </> "QuotaManager"
-    context  = if unsafe then bypassLocks "QuotaManager"
-                         else ($ database)
-
-  exists <- liftIO $ D.doesFileExist database
+  -- check for database
+  exists <- liftIO $ D.doesFileExist (dir </> "QuotaManager")
   when (not exists) (throwError "database is missing")
 
-  whitelist <- map pattern <$> asks whitelist
-  context $ \database -> do
+  whitelist <- map mkPattern <$> asks whitelist
+  withoutLocks "QuotaManager" $ \database -> do
     CE.handle dbErrors $ withSQLite database $ do
       bad <- S.query $ do
         quota <- S.select quotaOrigins
@@ -259,7 +250,7 @@ deleteQuotaOrigins = do
           S.restrict (url `S.like` S.the pattern)
           return S.true
     -- turns domains into patterns to match a url
-    pattern domain = "http%://%" <> domain <> "/"
+    mkPattern domain = "http%://%" <> domain <> "/"
 
 
 -- | Deletes per-domain files under the IndexedDB directory
@@ -429,14 +420,12 @@ deleteSessionStorage = do
 -- * Helper functions
 
 -- | Loads a leveldb database and runs a resourceT action
---
--- withDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
+withDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
 withDB path f = liftIO $ L.runResourceT (L.open path def >>= f)
 
 
 -- | Like 'withDB' but retry the action after repairing the db
---
--- withRetryDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
+withRetryDB :: FilePath -> (L.DB -> ResourceT IO a) -> Action a
 withRetryDB path action = do
   res <- CE.try (withDB path action)
   case res of
@@ -458,17 +447,20 @@ withRetryDB path action = do
 -- SQLite manages concurrent access via POSIX locks: these are tied to a
 -- specific file and pid. They can be bypassed by simply creating a hard
 -- link (pointing to the same inode), editing the link and then removing it.
-bypassLocks :: String -> (FilePath -> Action a) -> Action a
-bypassLocks dbName cont = do
+withoutLocks :: String -> (FilePath -> Action a) -> Action a
+withoutLocks dbName cont = do
   dir <- asks webenginePath
+  unsafe <- asks (unsafe . options)
   let
     real = dir </> dbName
     link = real <> "-bypass"
   -- bypass the SQLite POSIX locks with hard links
-  liftIO (Posix.createLink real link)
-  res <- cont database
+  when unsafe $ liftIO (Posix.createLink real link)
+
+  res <- cont (if unsafe then link else real)
+
   -- remove the hard links
-  liftIO (Posix.removeLink link)
+  when unsafe $ liftIO (Posix.removeLink link)
   return res
 
 

bisc.cabal

@@ -37,12 +37,12 @@ executable bisc
   main-is:             Main.hs
   build-depends:       base ==4.* , selda ==0.*,
                        selda-sqlite ==0.*,
-                       leveldb-haskell ==0.*,
-                       filepath, directory, text,
+                       leveldb-haskell ==0.*, resourcet,
+                       filepath, directory, text, unix,
                        mtl, configurator, exceptions,
                        data-default, bytestring,
                        optparse-applicative
   default-language:    Haskell2010
-  ghc-options:         -Wall
+  ghc-options:         -Wall -Wno-name-shadowing
   if flag(static)
     extra-libraries:   snappy stdc++