summaryrefslogtreecommitdiff
path: root/Database
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-02-18 16:56:52 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-02-18 16:56:52 -0400
commit814a3ea8c651f66a55638e0c40f13c1897b29a32 (patch)
tree6f46f53c612b6610eb49b9a16b9d6fe5483166ef /Database
parentd8125c9ea6d00b41f994162a0060f39e56107b12 (diff)
deal with rare SELECT ErrorBusy failures
I think they might be a sqlite bug. In discussions with sqlite devs.
Diffstat (limited to 'Database')
-rw-r--r--Database/Fsck.hs2
-rw-r--r--Database/Handle.hs19
2 files changed, 14 insertions, 7 deletions
diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index 92c814cf1..d249c8de6 100644
--- a/Database/Fsck.hs
+++ b/Database/Fsck.hs
@@ -96,7 +96,7 @@ addDb (FsckHandle h _) k = H.queueDb h 1000 $
sk = toSKey k
inDb :: FsckHandle -> Key -> IO Bool
-inDb (FsckHandle h _) = H.queryDb h . inDb' . toSKey
+inDb (FsckHandle h _) = H.queryDb h False . inDb' . toSKey
inDb' :: SKey -> SqlPersistM Bool
inDb' sk = do
diff --git a/Database/Handle.hs b/Database/Handle.hs
index 578bea31d..5d33105f2 100644
--- a/Database/Handle.hs
+++ b/Database/Handle.hs
@@ -100,13 +100,20 @@ workerThread db jobs = catchNonAsync loop showerr
- Only one action can be run at a time against a given DbHandle.
- If called concurrently in the same process, this will block until
- it is able to run.
+ -
+ - Warning: Under heavy traffic, this can fail with an exception
+ - that contains "ErrorBusy". WAL mode does not entirely prevent this.
+ - The fallback value is returned in this case.
-}
-queryDb :: DbHandle -> SqlPersistM a -> IO a
-queryDb (DbHandle _ jobs _) a = do
- res <- newEmptyMVar
- putMVar jobs $ QueryJob $
- liftIO . putMVar res =<< tryNonAsync a
- either throwIO return =<< takeMVar res
+queryDb :: DbHandle -> a -> SqlPersistM a -> IO a
+queryDb (DbHandle _ jobs _) fallback a =
+ catchNonAsync go (\_ -> return fallback )
+ where
+ go = do
+ res <- newEmptyMVar
+ putMVar jobs $ QueryJob $
+ liftIO . putMVar res =<< tryNonAsync a
+ either throwIO return =<< takeMVar res
closeDb :: DbHandle -> IO ()
closeDb h@(DbHandle worker jobs _) = do