Add delaySync and dealyMetaSync functions.

src/Database/LMDB/Simple.hs

@@ -54,6 +54,10 @@ module Database.LMDB.Simple
   , openReadOnlyEnvironment
   , readOnlyEnvironment
   , clearStaleReaders
+  , delaySync
+  , delayMetaSync
+  , isSyncDelayed
+  , isMetaSyncDelayed
 
     -- * Transactions
   , Transaction
@@ -81,7 +85,10 @@ module Database.LMDB.Simple
 import Control.Concurrent
   ( runInBoundThread
   )
-
+import Control.Concurrent.MVar
+  ( takeMVar
+  , putMVar
+  )
 import Control.Exception
   ( Exception
   , throwIO
@@ -95,19 +102,27 @@ import Control.Monad
   , void
   )
 
+import Control.Monad.IO.Class
+  ( MonadIO (liftIO)
+  )
+
 import Data.Coerce
   ( coerce
   )
 
 import Database.LMDB.Raw
   ( LMDB_Error (LMDB_Error, e_code)
-  , MDB_EnvFlag (MDB_NOSUBDIR, MDB_RDONLY)
+  , MDB_EnvFlag (MDB_NOSUBDIR, MDB_RDONLY, MDB_NOSYNC, MDB_NOMETASYNC)
   , MDB_DbFlag (MDB_CREATE)
   , mdb_env_create
   , mdb_env_open
+  , mdb_env_get_flags
+  , mdb_env_set_flags
   , mdb_env_set_mapsize
   , mdb_env_set_maxdbs
   , mdb_env_set_maxreaders
+  , mdb_env_sync_flush
+  , mdb_env_unset_flags
   , mdb_dbi_open'
   , mdb_txn_begin
   , mdb_txn_commit
@@ -129,6 +144,7 @@ import Database.LMDB.Simple.Internal
   , isReadOnlyEnvironment
   , isReadOnlyTransaction
   , isReadWriteTransaction
+  , mkNewEnvironment
   )
 import qualified Database.LMDB.Simple.Internal as Internal
 
@@ -191,8 +207,8 @@ openEnvironment path limits = do
   mdb_env_set_maxdbs     env (maxDatabases limits)
   mdb_env_set_maxreaders env (maxReaders   limits)
 
-  let environ = Env env :: Mode mode => Environment mode
-      flags   = [MDB_RDONLY | isReadOnlyEnvironment environ]
+  environ <- mkNewEnvironment env :: Mode mode => IO (Environment mode)
+  let flags   = [MDB_RDONLY | isReadOnlyEnvironment environ]
 
   r <- tryJust (guard . isNotDirectoryError) $ mdb_env_open env path flags
   case r of
@@ -228,7 +244,7 @@ readOnlyEnvironment = coerce
 -- | Check for stale entries in the reader lock table, and return the number
 -- of entries cleared.
 clearStaleReaders :: Environment mode -> IO Int
-clearStaleReaders (Env env) = mdb_reader_check env
+clearStaleReaders (Env env _ _) = mdb_reader_check env
 
 -- | Perform a top-level transaction in either 'ReadWrite' or 'ReadOnly'
 -- mode. A transaction may only be 'ReadWrite' if the environment is also
@@ -250,7 +266,7 @@ clearStaleReaders (Env env) = mdb_reader_check env
 -- serialized.
 transaction :: (Mode tmode, SubMode emode tmode)
             => Environment emode -> Transaction tmode a -> IO a
-transaction (Env env) tx@(Txn tf)
+transaction (Env env _ _) tx@(Txn tf)
   | isReadOnlyTransaction tx = run True
   | otherwise                = runInBoundThread (run False)
   where run readOnly =
@@ -343,3 +359,59 @@ put db key = maybe (void $ Internal.delete db key) (Internal.put db key)
 -- | Delete all key/value pairs from a database, leaving the database empty.
 clear :: Database k v -> Transaction ReadWrite ()
 clear (Db _ dbi) = Txn $ \txn -> mdb_clear' txn dbi
+
+-- | Delay flushing system buffer to disk when commiting transactions that are
+-- using the given read-write 'Environment' until after`m` completes.
+--
+-- This optimization means a system crash can corrupt the database or lose the
+-- last transactions if buffers are not yet flushed to disk. The risk is
+-- governed by how often the system flushes dirty buffers to disk.
+delaySync :: (MonadIO m) => Environment ReadWrite -> m a -> m a
+delaySync (Env e c _) m = do
+  c' <- liftIO $ takeMVar c
+  liftIO $ mdb_env_set_flags e [MDB_NOSYNC]
+  liftIO $ putMVar c (c' + 1)
+
+  result <- m
+  liftIO $ mdb_env_sync_flush e
+
+  c'' <- liftIO $ takeMVar c
+  if c'' <= 1
+    then do liftIO $ mdb_env_unset_flags e [MDB_NOSYNC]
+            liftIO $ putMVar c 0
+    else liftIO $ putMVar c (c'' - 1)
+  return result
+
+-- | Flush system buffers to disk only once per transaction, omit the metadata flush, for the
+-- given read-write 'Environment'.
+-- Defer that until the system flushes files to disk, or next non readonly transaction commit
+-- or after the mondadic action 'm' completes. This optimization maintains database integrity,
+-- but a system crash may undo the last committed transaction. I.e. it preserves the ACI
+-- (atomicity, consistency, isolation) but not D (durability) database property.
+delayMetaSync :: (MonadIO m) => Environment ReadWrite -> m a -> m a
+delayMetaSync (Env e _ c) m = do
+  c' <- liftIO $ takeMVar c
+  liftIO $ mdb_env_set_flags e [MDB_NOMETASYNC]
+  liftIO $ putMVar c (c' + 1)
+
+  result <- m
+  liftIO $ mdb_env_sync_flush e
+
+  c'' <- liftIO $ takeMVar c
+  if c'' <= 1
+    then do liftIO $ mdb_env_unset_flags e [MDB_NOMETASYNC]
+            liftIO $ putMVar c 0
+    else liftIO $ putMVar c (c'' - 1)
+  return result
+
+-- | Check if current 'Environment' delays flushing the system buffers to disk or not.
+isSyncDelayed :: Environment ReadWrite -> IO Bool
+isSyncDelayed e = isEnvFlagSet e MDB_NOSYNC
+
+-- | Check if current 'Environment' delays flushing the meta data to disk or not.
+isMetaSyncDelayed :: Environment ReadWrite -> IO Bool
+isMetaSyncDelayed e = isEnvFlagSet e MDB_NOMETASYNC
+
+-- | Checks if a flag is set on the current environment
+isEnvFlagSet :: Environment mode -> MDB_EnvFlag -> IO Bool
+isEnvFlagSet (Env e _ _) f = elem f <$> mdb_env_get_flags e

src/Database/LMDB/Simple/DBRef.hs

@@ -63,18 +63,18 @@ readDBRef ref@(Ref env dbi key) = transaction env (tx env ref)
 
   where tx :: Serialise a
            => Environment mode -> DBRef mode a -> Transaction ReadOnly (Maybe a)
-        tx (Env env) _ = getBS (Db env dbi) key
+        tx (Env env _ _) _ = getBS (Db env dbi) key
 
 -- | Write a new value into a 'DBRef'.
 writeDBRef :: Serialise a => DBRef ReadWrite a -> Maybe a -> IO ()
 writeDBRef (Ref env dbi key) = transaction env . maybe (delKey env) (putKey env)
 
   where delKey :: Environment ReadWrite -> Transaction ReadWrite ()
-        delKey (Env env) = void $ deleteBS (Db env dbi) key
+        delKey (Env env _ _) = void $ deleteBS (Db env dbi) key
 
         putKey :: Serialise a
                => Environment ReadWrite -> a -> Transaction ReadWrite ()
-        putKey (Env env) = putBS (Db env dbi) key
+        putKey (Env env _ _) = putBS (Db env dbi) key
 
 -- | Atomically mutate the contents of a 'DBRef'.
 modifyDBRef_ :: Serialise a => DBRef ReadWrite a -> (Maybe a -> Maybe a) -> IO ()
@@ -88,7 +88,7 @@ modifyDBRef (Ref env dbi key) = transaction env . tx env
   where tx :: Serialise a
            => Environment mode -> (Maybe a -> (Maybe a, b))
            -> Transaction ReadWrite b
-        tx (Env env) f = let db = Db env dbi in
+        tx (Env env _ _) f = let db = Db env dbi in
           getBS db key >>= \x -> let (x', r) = f x in
           maybe (void $ deleteBS db key) (putBS db key) x' >>
           return r

src/Database/LMDB/Simple/Internal.hs

@@ -16,6 +16,7 @@ module Database.LMDB.Simple.Internal
   , serialiseBS
   , marshalOut
   , marshalIn
+  , mkNewEnvironment
   , peekVal
   , forEachForward
   , forEachReverse
@@ -38,6 +39,10 @@ import Codec.Serialise
   , deserialise
   )
 
+import Control.Concurrent.MVar
+  ( MVar
+  , newMVar
+  )
 import Control.Exception
   ( assert
   , bracket
@@ -116,14 +121,23 @@ type family SubMode a b :: Constraint where
   SubMode a ReadOnly  = ()
 
 -- | An LMDB environment is a directory or file on disk that contains one or
--- more databases, and has an associated (reader) lock table.
-newtype Environment mode = Env MDB_env
+-- more databases, and has an associated (reader) lock table. It also contains
+-- counting 'MVar's for counting the calls for 'delaySync' and 'delayMetaSync'. 
+data Environment mode = Env {
+  env_Env :: MDB_env,
+  env_NoSyncCount     :: MVar Int,
+  env_MetaNoSyncCount :: MVar Int
+  }
 
 isReadOnlyEnvironment :: Mode mode => Environment mode -> Bool
 isReadOnlyEnvironment = isReadOnlyMode . mode
   where mode :: Environment mode -> mode
         mode = undefined
 
+-- | Creates a new 'Environment' out of a 'MDB_env'
+mkNewEnvironment :: MDB_env -> IO (Environment mode)
+mkNewEnvironment e = Env e <$> (newMVar 0) <*> (newMVar 0)
+
 -- | An LMDB transaction is an atomic unit for reading and/or changing one or
 -- more LMDB databases within an environment, during which the transaction has
 -- a consistent view of the database(s) and is unaffected by any other

test/Database/LMDB/SimpleSpec.hs

@@ -62,3 +62,27 @@ spec = beforeAll setup $ do
       ( do nestTransaction (put db 3 $ Just "three")
            get db 3
       ) `shouldReturn` Just "three"
+
+  describe "delaySync" $ do
+    it "sets the MDB_NOSYNC flag to on" $ \(env, _) ->
+      delaySync env $ (isSyncDelayed env) `shouldReturn` True
+    it "clears MDB_NOSYNC flag after the action completes" $ \(env, _) ->
+      (delaySync env (return ()) >> isSyncDelayed env) `shouldReturn` False
+    it "doesn't clear MDB_NOSYNC in a nested delaySync call" $ \(env, _) ->
+      (delaySync env $ delaySync env (return ()) >> isSyncDelayed env)
+      `shouldReturn` True
+    it "clears the MDB_NOSYNC flag after an action with a nested syncDelay call ends" $ \(env, _) ->
+      (delaySync env (delaySync env $ return ()) >> isSyncDelayed env)
+      `shouldReturn` False
+
+  describe "delayMetaSync" $ do
+    it "sets the MDB_NOMETASYNC flag to on" $ \(env, _) ->
+      delayMetaSync env $ (isMetaSyncDelayed env) `shouldReturn` True
+    it "clears MDB_NOMETASYNC flag after the action completes" $ \(env, _) ->
+      (delayMetaSync env (return ()) >> isMetaSyncDelayed env) `shouldReturn` False
+    it "doesn't clear MDB_NOMETASYNC in a nested delaySync call" $ \(env, _) ->
+      (delayMetaSync env $ delayMetaSync env (return ()) >> isMetaSyncDelayed env)
+      `shouldReturn` True
+    it "clears the MDB_NONETASYNC flag after an action with a nested syncDelay call ends" $ \(env, _) ->
+      (delayMetaSync env (delayMetaSync env $ return ()) >> isMetaSyncDelayed env)
+      `shouldReturn` False