1 files changed, 27 insertions, 7 deletions

diff --git a/Database/Handle.hs b/Database/Handle.hs
index b42c32812..59cab0e44 100644
--- a/Database/Handle.hs
+++ b/Database/Handle.hs
@@ -9,6 +9,8 @@ module Database.Handle (
 	DbHandle,
 	openDb,
 	runDb,
+	CommitPolicy(..),
+	runDb',
 	commitDb,
 	closeDb,
 ) where
@@ -17,15 +19,17 @@ import Utility.Exception
 
 import Database.Persist.Sqlite (runSqlite)
 import Database.Esqueleto hiding (Key)
+import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Exception (throwIO)
 import qualified Data.Text as T
+import Data.Time.Clock
 
 {- A DbHandle is a reference to a worker thread that communicates with
  - the database. It has a MVar which Jobs are submitted to. -}
-data DbHandle = DbHandle (Async ()) (MVar Job)
+data DbHandle = DbHandle (Async ()) (MVar Job) (MVar UTCTime)
 
 data Job = RunJob (SqlPersistM ()) | CommitJob | CloseJob
 
@@ -33,7 +37,8 @@ openDb :: FilePath -> IO DbHandle
 openDb db = do
 	jobs <- newEmptyMVar
 	worker <- async (workerThread (T.pack db) jobs)
-	return $ DbHandle worker jobs
+	t <- newMVar =<< getCurrentTime
+	return $ DbHandle worker jobs t
 
 workerThread :: T.Text -> MVar Job -> IO ()
 workerThread db jobs = go
@@ -50,26 +55,41 @@ workerThread db jobs = go
 			CommitJob -> return CommitJob
 			CloseJob -> return CloseJob
 
+
 {- Runs an action using the DbHandle.
  -
  - Note that the action is not run by the calling thread, but by a
  - worker thread. Exceptions are propigated to the calling thread.
  -
- - Note that only one action can be run at a time against a given DbHandle.
+ - Only one action can be run at a time against a given DbHandle.
  - If called concurrently, this will block until it is able to run.
  -}
 runDb :: DbHandle -> SqlPersistM a -> IO a
-runDb (DbHandle _ jobs) a = do
+runDb h = runDb' h CommitManually
+
+data CommitPolicy = CommitManually | CommitAfterSeconds Int
+
+runDb' :: DbHandle -> CommitPolicy -> SqlPersistM a -> IO a
+runDb' h@(DbHandle _ jobs t) pol a = do
 	res <- newEmptyMVar
 	putMVar jobs $ RunJob $ liftIO . putMVar res =<< tryNonAsync a
-	either throwIO return =<< takeMVar res
+	r <- either throwIO return =<< takeMVar res
+	case pol of
+		CommitManually -> return ()
+		CommitAfterSeconds n -> do
+			now <- getCurrentTime
+			prev <- takeMVar t
+			putMVar t now
+			when (diffUTCTime now prev > fromIntegral n) $
+				commitDb h
+	return r
 
 {- Commits any transaction that was created by the previous calls to runDb,
  - and starts a new transaction. -}
 commitDb :: DbHandle -> IO ()
-commitDb (DbHandle _ jobs) = putMVar jobs CommitJob
+commitDb (DbHandle _ jobs _) = putMVar jobs CommitJob
 
 closeDb :: DbHandle -> IO ()
-closeDb (DbHandle worker jobs) = do
+closeDb (DbHandle worker jobs _) = do
 	putMVar jobs CloseJob
 	wait worker