{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Streamly.External.LMDB.Internal where

import Control.Concurrent
import qualified Control.Concurrent.Lifted as LI
import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Control.Exception.Lifted as LI
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import Data.Foldable
import Data.Kind
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Foreign hiding (void)
import Foreign.C
import GHC.TypeLits
import Streamly.Data.Fold (Fold)
import qualified Streamly.Data.Fold as F
import qualified Streamly.Data.Stream.Prelude as S
import Streamly.External.LMDB.Internal.Error
import Streamly.External.LMDB.Internal.Foreign
import qualified Streamly.Internal.Data.Fold as F
import Streamly.Internal.Data.IOFinalizer
import Streamly.Internal.Data.Stream (Stream)
import Streamly.Internal.Data.Unfold (Unfold)
import qualified Streamly.Internal.Data.Unfold as U
import System.Directory
import System.Mem
import Text.Printf

isReadOnlyEnvironment :: forall emode. (Mode emode) => Bool
isReadOnlyEnvironment :: forall emode. Mode emode => Bool
isReadOnlyEnvironment =
  forall a. Mode a => a -> Bool
isReadOnlyMode @emode (String -> emode
forall a. HasCallStack => String -> a
error String
"isReadOnlyEnvironment: unreachable")

-- | LMDB environments have various limits on the size and number of databases and concurrent
-- readers.
data Limits = Limits
  { -- | Memory map size, in bytes (also the maximum size of all databases).
    Limits -> Int
mapSize :: !Int,
    -- | Maximum number of named databases.
    Limits -> Int
maxDatabases :: !Int,
    -- | Maximum number of concurrent 'ReadOnly' transactions
    --   (also the number of slots in the lock table).
    Limits -> Int
maxReaders :: !Int
  }

-- | The default limits are 1 MiB map size, 0 named databases (see [Databases](#g:databases)), and
-- 126 concurrent readers. These can be adjusted freely, and in particular the 'mapSize' may be set
-- very large (limited only by available address space). However, LMDB is not optimized for a large
-- number of named databases so 'maxDatabases' should be kept to a minimum.
--
-- The default 'mapSize' is intentionally small, and should be changed to something appropriate for
-- your application. It ought to be a multiple of the OS page size, and should be chosen as large as
-- possible to accommodate future growth of the database(s). Once set for an environment, this limit
-- cannot be reduced to a value smaller than the space already consumed by the environment; however,
-- it can later be increased.
--
-- If you are going to use any named databases then you will need to change 'maxDatabases' to the
-- number of named databases you plan to use. However, you do not need to change this field if you
-- are only going to use the single main (unnamed) database.
defaultLimits :: Limits
defaultLimits :: Limits
defaultLimits =
  Limits
    { mapSize :: Int
mapSize = Int
forall a. Num a => a
mebibyte,
      maxDatabases :: Int
maxDatabases = Int
0,
      maxReaders :: Int
maxReaders = Int
126
    }

-- | Open an LMDB environment in either 'ReadWrite' or 'ReadOnly' mode. The 'FilePath' argument may
-- be either a directory or a regular file, but it must already exist; when creating a new
-- environment, one should create an empty file or directory beforehand. If a regular file, an
-- additional file with "-lock" appended to the name is automatically created for the reader lock
-- table.
--
-- Note that an environment must have been opened in 'ReadWrite' mode at least once before it can be
-- opened in 'ReadOnly' mode.
--
-- An environment opened in 'ReadOnly' mode may still modify the reader lock table (except when the
-- filesystem is read-only, in which case no locks are used).
--
-- To satisfy certain low-level LMDB requirements, please do not have opened the same environment
-- (i.e., the same 'FilePath') more than once in the same process at the same time. Furthermore,
-- please use the environment in the process that opened it (not after forking a new process).
openEnvironment :: forall emode. (Mode emode) => FilePath -> Limits -> IO (Environment emode)
openEnvironment :: forall emode.
Mode emode =>
String -> Limits -> IO (Environment emode)
openEnvironment String
path Limits
limits = IO (Environment emode) -> IO (Environment emode)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Environment emode) -> IO (Environment emode))
-> IO (Environment emode) -> IO (Environment emode)
forall a b. (a -> b) -> a -> b
$ do
  -- Low-level requirements:
  -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L100,
  -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L102

  Ptr MDB_env
penv <- IO (Ptr MDB_env)
mdb_env_create
  IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
    ( do
        Ptr MDB_env -> Int -> IO ()
mdb_env_set_mapsize Ptr MDB_env
penv Limits
limits.mapSize
        let maxDbs :: Int
maxDbs = Limits
limits.maxDatabases in Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxDbs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr MDB_env -> Int -> IO ()
mdb_env_set_maxdbs Ptr MDB_env
penv Int
maxDbs
        Ptr MDB_env -> Int -> IO ()
mdb_env_set_maxreaders Ptr MDB_env
penv Limits
limits.maxReaders

        Bool
exists <- String -> IO Bool
doesPathExist String
path
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError
            String
"openEnvironment"
            ( String
"no file or directory found at the specified path; "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"please create an empty file or directory beforehand"
            )

        Bool
isDir <- String -> IO Bool
doesDirectoryExist String
path

        -- Always use MDB_NOTLS, which is crucial for Haskell applications; see
        -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L615
        let isRo :: Bool
isRo = forall emode. Mode emode => Bool
isReadOnlyEnvironment @emode
            flags :: [CUInt]
flags = CUInt
mdb_notls CUInt -> [CUInt] -> [CUInt]
forall a. a -> [a] -> [a]
: ([CUInt
mdb_rdonly | Bool
isRo] [CUInt] -> [CUInt] -> [CUInt]
forall a. [a] -> [a] -> [a]
++ [CUInt
mdb_nosubdir | Bool -> Bool
not Bool
isDir])

        (LMDB_Error -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
          ( \case
              LMDB_Error {e_code :: LMDB_Error -> Either Int MDB_ErrCode
e_code = Left Int
code}
                | CInt -> Errno
Errno (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code) Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eNOENT Bool -> Bool -> Bool
&& Bool
isRo -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
              LMDB_Error
_ -> Maybe ()
forall a. Maybe a
Nothing
          )
          (Ptr MDB_env -> String -> CUInt -> IO ()
mdb_env_open Ptr MDB_env
penv String
path ([CUInt] -> CUInt
combineOptions [CUInt]
flags))
          ( \() ->
              -- Provide a friendlier error for a presumably common user mistake.
              String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError
                String
"openEnvironment"
                ( String
"mdb_env_open returned 2 (ENOENT); "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"one possibility is that a new empty environment "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"wasn't first opened in ReadWrite mode"
                )
          )
    )
    -- In particular if mdb_env_open fails, the environment must be closed; see
    -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L546
    (Ptr MDB_env -> IO ()
c_mdb_env_close Ptr MDB_env
penv)

  (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars <-
    (,,,)
      (TMVarS NumReaders
 -> WriteLock
 -> WriteThread
 -> CloseDbLock
 -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
-> IO (TMVarS NumReaders)
-> IO
     (WriteLock
      -> WriteThread
      -> CloseDbLock
      -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumReaders -> IO (TMVarS NumReaders)
forall a. a -> IO (TMVarS a)
newTMVarSIO NumReaders
0
      IO
  (WriteLock
   -> WriteThread
   -> CloseDbLock
   -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
-> IO WriteLock
-> IO
     (WriteThread
      -> CloseDbLock
      -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MVar () -> WriteLock
WriteLock (MVar () -> WriteLock) -> IO (MVar ()) -> IO WriteLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar)
      IO
  (WriteThread
   -> CloseDbLock
   -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
-> IO WriteThread
-> IO
     (CloseDbLock
      -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MVar ThreadId -> WriteThread
WriteThread (MVar ThreadId -> WriteThread)
-> IO (MVar ThreadId) -> IO WriteThread
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar ThreadId)
forall a. IO (MVar a)
newEmptyMVar)
      IO
  (CloseDbLock
   -> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock))
-> IO CloseDbLock
-> IO (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MVar () -> CloseDbLock
CloseDbLock (MVar () -> CloseDbLock) -> IO (MVar ()) -> IO CloseDbLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ())

  Environment emode -> IO (Environment emode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Environment emode -> IO (Environment emode))
-> Environment emode -> IO (Environment emode)
forall a b. (a -> b) -> a -> b
$ Ptr MDB_env
-> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
-> Environment emode
forall {k} (emode :: k).
Ptr MDB_env
-> (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
-> Environment emode
Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars

-- | Closes the given environment.
--
-- If you have merely a few dozen environments at most, there should be no need for this. (It is a
-- common practice with LMDB to create one’s environments once and reuse them for the remainder of
-- the program’s execution.)
--
-- To satisfy certain low-level LMDB requirements:
--
-- * Before calling this function, please call 'closeDatabase' on all databases in the environment.
-- * Before calling this function, close all cursors and commit\/abort all transactions on the
--   environment. To make sure this requirement is satisified for read-only transactions, either (a)
--   call 'waitReaders' or (b) pass precreated cursors/transactions to 'readLMDB' and
--   'unsafeReadLMDB'.
-- * After calling this function, do not use the environment or any related databases, transactions,
--   and cursors.
closeEnvironment :: forall emode. (Mode emode) => Environment emode -> IO ()
closeEnvironment :: forall emode. Mode emode => Environment emode -> IO ()
closeEnvironment (Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
_) = do
  -- An environment should only be closed once, so the low-level concurrency requirements should be
  -- fulfilled:
  -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L787
  Ptr MDB_env -> IO ()
c_mdb_env_close Ptr MDB_env
penv

-- | Gets a database with the given name.
--
-- If only one database is desired within the environment, the name can be 'Nothing' (known as the
-- “unnamed database”).
--
-- If one or more named databases (a database with a 'Just' name) are desired, the 'maxDatabases' of
-- the environment’s limits should have been adjusted accordingly. The unnamed database will in this
-- case contain the names of the named databases as keys, which one is allowed to read but not
-- write.
--
-- /Warning/: When getting a named database for the first time (i.e., creating it), one must do so
-- in the 'ReadWrite' environment mode. (This restriction does not apply for the unnamed database.)
-- In this case, this function spawns a bound thread and creates a temporary read-write transaction
-- under the hood; see [Transactions](#g:transactions).
getDatabase ::
  forall emode.
  (Mode emode) =>
  Environment emode ->
  Maybe String ->
  IO (Database emode)
getDatabase :: forall emode.
Mode emode =>
Environment emode -> Maybe String -> IO (Database emode)
getDatabase env :: Environment emode
env@(Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) Maybe String
mName = IO (Database emode) -> IO (Database emode)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Database emode) -> IO (Database emode))
-> IO (Database emode) -> IO (Database emode)
forall a b. (a -> b) -> a -> b
$ do
  -- To satisfy the lower-level concurrency requirements mentioned at
  -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L1118
  -- we imagine, for simplicity, that everything below is a read-write transaction. Thusly, we also
  -- satisfy the MDB_NOTLS read-write transaction serialization requirement (for the case where a
  -- read-write transaction actually occur below). This simplification shouldn’t cause any problems,
  -- esp. since this function is presumably called relatively rarely in practice.

  let (TMVarS NumReaders
_, WriteLock MVar ()
lock, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock () -- Interruptible when waiting for other read-write transactions.
  let disclaimWriteOwnership :: IO ()
disclaimWriteOwnership = MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock

  MDB_dbi_t
dbi <-
    IO MDB_dbi_t -> IO () -> IO MDB_dbi_t
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally
      ( case Maybe String
mName of
          Maybe String
Nothing -> do
            -- Use a read-only transaction to get the unnamed database. (MDB_CREATE is never needed
            -- for the unnamed database.)
            Ptr MDB_txn
ptxn <- Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
mdb_rdonly
            IO MDB_dbi_t -> IO () -> IO MDB_dbi_t
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
              (Ptr MDB_txn -> Maybe String -> CUInt -> IO MDB_dbi_t
mdb_dbi_open Ptr MDB_txn
ptxn Maybe String
forall a. Maybe a
Nothing CUInt
0 IO MDB_dbi_t -> IO () -> IO MDB_dbi_t
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Ptr MDB_txn -> IO ()
mdb_txn_commit Ptr MDB_txn
ptxn)
              (Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn)
          Just String
name -> do
            Maybe MDB_dbi_t
mdbi <- Environment emode -> String -> IO (Maybe MDB_dbi_t)
forall emode.
Mode emode =>
Environment emode -> String -> IO (Maybe MDB_dbi_t)
getNamedDb Environment emode
env String
name
            case Maybe MDB_dbi_t
mdbi of
              Just MDB_dbi_t
dbi ->
                MDB_dbi_t -> IO MDB_dbi_t
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MDB_dbi_t
dbi
              Maybe MDB_dbi_t
Nothing ->
                -- The named database was not found.
                if forall emode. Mode emode => Bool
isReadOnlyEnvironment @emode
                  then
                    String -> String -> IO MDB_dbi_t
forall (m :: * -> *) a. String -> String -> m a
throwError
                      String
"getDatabase"
                      ( String
"please use the ReadWrite environment mode for getting a named database "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"for the first time (i.e., for creating a named database)"
                      )
                  else
                    -- Use a read-write transaction to create the named database.
                    --
                    -- We run this in a bound thread to make sure the read-write transaction doesn’t
                    -- cross OS threads. (We do this ourselves instead of putting this burden on the
                    -- user because this function is presumably called relatively rarely in
                    -- practice.)
                    IO MDB_dbi_t -> IO MDB_dbi_t
forall a. IO a -> IO a
runInBoundThread (IO MDB_dbi_t -> IO MDB_dbi_t) -> IO MDB_dbi_t -> IO MDB_dbi_t
forall a b. (a -> b) -> a -> b
$ do
                      Ptr MDB_txn
ptxn <- Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
0
                      IO MDB_dbi_t -> IO () -> IO MDB_dbi_t
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
                        (Ptr MDB_txn -> Maybe String -> CUInt -> IO MDB_dbi_t
mdb_dbi_open Ptr MDB_txn
ptxn (String -> Maybe String
forall a. a -> Maybe a
Just String
name) CUInt
mdb_create IO MDB_dbi_t -> IO () -> IO MDB_dbi_t
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Ptr MDB_txn -> IO ()
mdb_txn_commit Ptr MDB_txn
ptxn)
                        (Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn)
      )
      IO ()
disclaimWriteOwnership

  Database emode -> IO (Database emode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Database emode -> IO (Database emode))
-> Database emode -> IO (Database emode)
forall a b. (a -> b) -> a -> b
$ Environment emode -> MDB_dbi_t -> Database emode
forall {k} (emode :: k).
Environment emode -> MDB_dbi_t -> Database emode
Database Environment emode
env MDB_dbi_t
dbi

-- | Closes the given database.
--
-- If you have merely a few dozen databases at most, there should be no need for this. (It is a
-- common practice with LMDB to create one’s databases once and reuse them for the remainder of the
-- program’s execution.)
--
-- To satisfy certain low-level LMDB requirements:
--
-- * Before calling this function, please make sure all read-write transactions that have modified
--   the database have already been committed or aborted.
-- * After calling this function, do not use the database or any of its cursors again. To make sure
--   this requirement is satisfied for cursors on read-only transactions, either (a) call
--   'waitReaders' or (b) pass precreated cursors/transactions to 'readLMDB' and 'unsafeReadLMDB'.
closeDatabase :: forall emode. (Mode emode) => Database emode -> IO ()
closeDatabase :: forall emode. Mode emode => Database emode -> IO ()
closeDatabase (Database (Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) MDB_dbi_t
dbi) = do
  -- We need to serialize the closing; see
  -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L1200
  let (TMVarS NumReaders
_, WriteLock
_, WriteThread
_, CloseDbLock MVar ()
lock) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \() ->
    Ptr MDB_env -> MDB_dbi_t -> IO ()
c_mdb_dbi_close Ptr MDB_env
penv MDB_dbi_t
dbi

-- | A type for an optional thing where we want to fix the transaction mode to @ReadOnly@ in the
-- nothing case. (@Maybe@ isn’t powerful enough for this.)
data MaybeTxn tmode a where
  NoTxn :: MaybeTxn ReadOnly a
  JustTxn :: a -> MaybeTxn tmode a

-- | A type for an @Either@-like choice where we want to fix the transaction mode to @ReadOnly@ in
-- the @Left@ case. (@Either@ isn’t powerful enough for this.)
data EitherTxn tmode a b where
  LeftTxn :: a -> EitherTxn ReadOnly a b
  RightTxn :: b -> EitherTxn tmode a b

-- | Use @unsafe@ FFI calls under the hood. This can increase iteration speed, but one should
-- bear in mind that @unsafe@ FFI calls, since they block all other threads, can have an adverse
-- impact on the performance of the rest of the program.
--
-- /Internal/.
newtype UseUnsafeFFI = UseUnsafeFFI Bool deriving (Int -> UseUnsafeFFI -> String -> String
[UseUnsafeFFI] -> String -> String
UseUnsafeFFI -> String
(Int -> UseUnsafeFFI -> String -> String)
-> (UseUnsafeFFI -> String)
-> ([UseUnsafeFFI] -> String -> String)
-> Show UseUnsafeFFI
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UseUnsafeFFI -> String -> String
showsPrec :: Int -> UseUnsafeFFI -> String -> String
$cshow :: UseUnsafeFFI -> String
show :: UseUnsafeFFI -> String
$cshowList :: [UseUnsafeFFI] -> String -> String
showList :: [UseUnsafeFFI] -> String -> String
Show)

-- | Creates an unfold with which we can stream key-value pairs from the given database.
--
-- If an existing transaction and cursor are not provided, there are two possibilities: (a) If a
-- chunk size is not provided, a read-only transaction and cursor are automatically created for the
-- entire duration of the unfold. (b) Otherwise, new transactions and cursors are automatically
-- created according to the desired chunk size. In this case, each transaction (apart from the first
-- one) starts as expected at the key next to (i.e., the largest\/smallest key less\/greater than)
-- the previously encountered key.
--
-- If you want to iterate through a large database while avoiding a long-lived transaction (see
-- [Transactions](#g:transactions)), it is your responsibility to either chunk up your usage of
-- 'readLMDB' (with which 'readStart' can help) or specify a chunk size as described above.
--
-- Runtime consideration: If you call 'readLMDB' very frequently without a precreated transaction
-- and cursor, you might find upon profiling that a significant time is being spent at
-- @mdb_txn_begin@, or find yourself having to increase 'maxReaders' in the environment’s limits
-- because the transactions and cursors are not being garbage collected fast enough. In this case,
-- please consider precreating a transaction and cursor.
--
-- If you don’t want the overhead of intermediate @ByteString@s (on your way to your eventual data
-- structures), use 'unsafeReadLMDB' instead.
{-# INLINE readLMDB #-}
readLMDB ::
  forall m emode tmode.
  (MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
  Unfold
    m
    ( ReadOptions,
      Database emode,
      EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
    )
    (ByteString, ByteString)
readLMDB :: forall (m :: * -> *) emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
  (ByteString, ByteString)
readLMDB =
  ((ReadOptions, Database emode,
  EitherTxn
    tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
 -> (ReadOptions, UseUnsafeFFI, Database emode,
     EitherTxn
       tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)))
-> Unfold
     m
     (ReadOptions, UseUnsafeFFI, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
     (ByteString, ByteString)
-> Unfold
     m
     (ReadOptions, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
     (ByteString, ByteString)
forall a c (m :: * -> *) b.
(a -> c) -> Unfold m c b -> Unfold m a b
U.lmap
    (\(ReadOptions
ropts, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs) -> (ReadOptions
ropts, Bool -> UseUnsafeFFI
UseUnsafeFFI Bool
False, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs))
    Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
  (ByteString, ByteString)
forall (m :: * -> *) emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
  (ByteString, ByteString)
readLMDB'

-- | Similar to 'readLMDB', except that it has an extra 'UseUnsafeFFI' parameter.
--
-- /Internal/.
{-# INLINE readLMDB' #-}
readLMDB' ::
  forall m emode tmode.
  (MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
  Unfold
    m
    ( ReadOptions,
      UseUnsafeFFI,
      Database emode,
      EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
    )
    (ByteString, ByteString)
readLMDB' :: forall (m :: * -> *) emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
  (ByteString, ByteString)
readLMDB' =
  ((ReadOptions, UseUnsafeFFI, Database emode,
  EitherTxn
    tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
 -> (ReadOptions, UseUnsafeFFI, Database emode,
     EitherTxn
       tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
     CStringLen -> IO ByteString, CStringLen -> IO ByteString))
-> Unfold
     m
     (ReadOptions, UseUnsafeFFI, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO ByteString, CStringLen -> IO ByteString)
     (ByteString, ByteString)
-> Unfold
     m
     (ReadOptions, UseUnsafeFFI, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor))
     (ByteString, ByteString)
forall a c (m :: * -> *) b.
(a -> c) -> Unfold m c b -> Unfold m a b
U.lmap
    (\(ReadOptions
ropts, UseUnsafeFFI
us, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs) -> (ReadOptions
ropts, UseUnsafeFFI
us, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs, CStringLen -> IO ByteString
B.packCStringLen, CStringLen -> IO ByteString
B.packCStringLen))
    Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO ByteString, CStringLen -> IO ByteString)
  (ByteString, ByteString)
forall (m :: * -> *) k v emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO k, CStringLen -> IO v)
  (k, v)
unsafeReadLMDB'

-- | Similar to 'readLMDB', except that the keys and values are not automatically converted into
-- Haskell @ByteString@s.
--
-- To ensure safety, please make sure that the memory pointed to by the 'CStringLen' for each
-- key/value mapping function call is (a) only read (and not written to); and (b) not used after the
-- mapping function has returned. One way to transform the 'CStringLen's to your desired data
-- structures is to use 'Data.ByteString.Unsafe.unsafePackCStringLen'.
{-# INLINE unsafeReadLMDB #-}
unsafeReadLMDB ::
  forall m k v emode tmode.
  (MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
  Unfold
    m
    ( ReadOptions,
      Database emode,
      EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO k,
      CStringLen -> IO v
    )
    (k, v)
unsafeReadLMDB :: forall (m :: * -> *) k v emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO k, CStringLen -> IO v)
  (k, v)
unsafeReadLMDB =
  ((ReadOptions, Database emode,
  EitherTxn
    tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
  CStringLen -> IO k, CStringLen -> IO v)
 -> (ReadOptions, UseUnsafeFFI, Database emode,
     EitherTxn
       tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
     CStringLen -> IO k, CStringLen -> IO v))
-> Unfold
     m
     (ReadOptions, UseUnsafeFFI, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO k, CStringLen -> IO v)
     (k, v)
-> Unfold
     m
     (ReadOptions, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO k, CStringLen -> IO v)
     (k, v)
forall a c (m :: * -> *) b.
(a -> c) -> Unfold m c b -> Unfold m a b
U.lmap
    (\(ReadOptions
ropts, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs, CStringLen -> IO k
kmap, CStringLen -> IO v
vmap) -> (ReadOptions
ropts, Bool -> UseUnsafeFFI
UseUnsafeFFI Bool
False, Database emode
db, EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs, CStringLen -> IO k
kmap, CStringLen -> IO v
vmap))
    Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO k, CStringLen -> IO v)
  (k, v)
forall (m :: * -> *) k v emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO k, CStringLen -> IO v)
  (k, v)
unsafeReadLMDB'

-- | Similar to 'unsafeReadLMDB', except that it has an extra 'UseUnsafeFFI' parameter.
--
-- /Internal/.
{-# INLINE unsafeReadLMDB' #-}
unsafeReadLMDB' ::
  forall m k v emode tmode.
  (MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
  Unfold
    m
    ( ReadOptions,
      UseUnsafeFFI,
      Database emode,
      EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO k,
      CStringLen -> IO v
    )
    (k, v)
unsafeReadLMDB' :: forall (m :: * -> *) k v emode tmode.
(MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
Unfold
  m
  (ReadOptions, UseUnsafeFFI, Database emode,
   EitherTxn
     tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
   CStringLen -> IO k, CStringLen -> IO v)
  (k, v)
unsafeReadLMDB' =
  -- Performance notes:
  -- + Unfortunately, introducing ChunkSize support increased overhead compared to C from around 50
  --   ns/pair to around 90 ns/s (for the safe FFI case).
  -- + We mention below what things helped with performance.
  -- + We tried various other things (e.g., using [0] or [4] phase control for the inlined
  --   subfunctions, wrapping changing state in IORefs, etc.), but to no avail.
  -- + For now, we presume that there is simply not much more gain left to achieve, given the extra
  --   workload needed for the chunking support. (TODO: We noticed that removing the unsafe FFI
  --   support altogether seems to give around 5 ns/pair speedup, but for now we don’t bother.)
  let {-# INLINE newTxnCurs #-}
      newTxnCurs ::
        (Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)) ->
        (Ptr MDB_txn -> IO ()) ->
        (Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)) ->
        (Ptr MDB_cursor -> IO ()) ->
        Ptr MDB_env ->
        MDB_dbi_t ->
        TMVarS NumReaders ->
        IO (Ptr MDB_cursor, IOFinalizer)
      newTxnCurs :: (Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn))
-> (Ptr MDB_txn -> IO ())
-> (Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor))
-> (Ptr MDB_cursor -> IO ())
-> Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
newTxnCurs
        Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
txn_begin
        Ptr MDB_txn -> IO ()
txn_abort
        Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
cursor_open
        Ptr MDB_cursor -> IO ()
cursor_close
        Ptr MDB_env
penv
        MDB_dbi_t
dbi
        TMVarS NumReaders
numReadersT =
          IO (Ptr MDB_cursor, IOFinalizer)
-> IO (Ptr MDB_cursor, IOFinalizer)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Ptr MDB_cursor, IOFinalizer)
 -> IO (Ptr MDB_cursor, IOFinalizer))
-> IO (Ptr MDB_cursor, IOFinalizer)
-> IO (Ptr MDB_cursor, IOFinalizer)
forall a b. (a -> b) -> a -> b
$ do
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              NumReaders
n <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
              TMVarS NumReaders -> NumReaders -> STM ()
forall a. TMVarS a -> a -> STM ()
putTMVarS TMVarS NumReaders
numReadersT (NumReaders -> STM ()) -> NumReaders -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
n NumReaders -> NumReaders -> NumReaders
forall a. Num a => a -> a -> a
+ NumReaders
1

            let decrReaders :: IO ()
decrReaders = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  -- This should, when this is called, never be interruptible because we are, of
                  -- course, finishing up a reader that is still known to exist.
                  NumReaders
n <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
                  TMVarS NumReaders -> NumReaders -> STM ()
forall a. TMVarS a -> a -> STM ()
putTMVarS TMVarS NumReaders
numReadersT (NumReaders -> STM ()) -> NumReaders -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
n NumReaders -> NumReaders -> NumReaders
forall a. Num a => a -> a -> a
- NumReaders
1

            Ptr MDB_txn
ptxn <-
              IO (Ptr MDB_txn) -> IO () -> IO (Ptr MDB_txn)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
                (Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
mdb_rdonly)
                IO ()
decrReaders

            Ptr MDB_cursor
pcurs <-
              IO (Ptr MDB_cursor) -> IO () -> IO (Ptr MDB_cursor)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
                (Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
cursor_open Ptr MDB_txn
ptxn MDB_dbi_t
dbi)
                (Ptr MDB_txn -> IO ()
txn_abort Ptr MDB_txn
ptxn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
decrReaders)

            IOFinalizer
txnCursRef <-
              IO IOFinalizer -> IO () -> IO IOFinalizer
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
                ( do
                    IO () -> IO IOFinalizer
forall (m :: * -> *) a. MonadIO m => IO a -> m IOFinalizer
newIOFinalizer (IO () -> IO IOFinalizer)
-> (IO () -> IO ()) -> IO () -> IO IOFinalizer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO IOFinalizer) -> IO () -> IO IOFinalizer
forall a b. (a -> b) -> a -> b
$ do
                      -- With LMDB, there is ordinarily no need to commit read-only transactions.
                      -- (The exception is when we want to make databases that were opened during
                      -- the transaction available later, but that’s not applicable here.) We can
                      -- therefore abort ptxn, both for failure (exceptions) and success.
                      --
                      -- Note furthermore that this should be sound in the face of asynchronous
                      -- exceptions (where this finalizer could get called from a different thread)
                      -- because LMDB with MDB_NOTLS allows for read-only transactions being used
                      -- from multiple threads; see
                      -- https://github.com/LMDB/lmdb/blob/8d0cbbc936091eb85972501a9b31a8f86d4c51a7/libraries/liblmdb/lmdb.h#L984
                      Ptr MDB_cursor -> IO ()
cursor_close Ptr MDB_cursor
pcurs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr MDB_txn -> IO ()
txn_abort Ptr MDB_txn
ptxn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
decrReaders
                )
                (Ptr MDB_cursor -> IO ()
cursor_close Ptr MDB_cursor
pcurs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr MDB_txn -> IO ()
txn_abort Ptr MDB_txn
ptxn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
decrReaders)

            (Ptr MDB_cursor, IOFinalizer) -> IO (Ptr MDB_cursor, IOFinalizer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr MDB_cursor
pcurs, IOFinalizer
txnCursRef)

      {-# INLINE positionCurs #-}
      positionCurs ::
        (Ptr MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> MDB_cursor_op_t -> IO CInt) ->
        ReadStart ->
        Ptr MDB_cursor ->
        Ptr MDB_val ->
        Ptr MDB_val ->
        -- Three possibilities (cursor_get return value): 0 (found), mdb_notfound (not found), other
        -- non-zero (error).
        IO CInt
      positionCurs :: (Ptr MDB_cursor
 -> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt)
-> ReadStart
-> Ptr MDB_cursor
-> Ptr MDB_val
-> Ptr MDB_val
-> IO CInt
positionCurs Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get ReadStart
readStart Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv =
        case ReadStart
readStart of
          ReadStart
ReadBeg -> Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_first
          ReadStart
ReadEnd -> Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_last
          ReadGE ByteString
k -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) -> do
            Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
pk (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp)
            Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_set_range
          -- For the other cases, LMDB has no built-in operators; so we simulate them ourselves.
          ReadGT ByteString
k -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) -> do
            Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
pk (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp)
            CInt
rc <- Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_set_range
            if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
              then do
                ByteString
k' <- Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek Ptr MDB_val
pk IO MDB_val -> (MDB_val -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x -> CStringLen -> IO ByteString
B.unsafePackCStringLen (MDB_val
x.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size)
                if ByteString
k' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
k
                  then Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_next
                  else CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
rc
              else
                -- Error; or not found (if GE is not found, GT doesn’t exist either).
                CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
rc
          ReadLE ByteString
k -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) -> do
            Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
pk (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp)
            CInt
rc <- Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_set_range
            if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
              then do
                ByteString
k' <- Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek Ptr MDB_val
pk IO MDB_val -> (MDB_val -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x -> CStringLen -> IO ByteString
B.unsafePackCStringLen (MDB_val
x.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size)
                if ByteString
k' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
k
                  then CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
rc
                  else Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_prev
              else do
                if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
mdb_notfound
                  then Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_last
                  else CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
rc
          ReadLT ByteString
k -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) -> do
            Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
pk (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp)
            CInt
rc <- Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_set_range
            if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
              then
                -- In both GE and GT cases, find the previous one (to reach LT).
                Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_prev
              else do
                if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
mdb_notfound
                  then Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv MDB_dbi_t
mdb_last
                  else CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
rc
   in (((CInt, Int, Ptr MDB_cursor, IOFinalizer),
  ReadLMDBFixed_ emode k v)
 -> m (Step
         ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
          ReadLMDBFixed_ emode k v)
         (k, v)))
-> ((ReadOptions, UseUnsafeFFI, Database emode,
     EitherTxn
       tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
     CStringLen -> IO k, CStringLen -> IO v)
    -> m ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
          ReadLMDBFixed_ emode k v))
-> Unfold
     m
     (ReadOptions, UseUnsafeFFI, Database emode,
      EitherTxn
        tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor),
      CStringLen -> IO k, CStringLen -> IO v)
     (k, v)
forall (m :: * -> *) a b s.
(s -> m (Step s b)) -> (a -> m s) -> Unfold m a b
U.Unfold
        ( \( (CInt
rc, Int
chunkSz, Ptr MDB_cursor
pcurs, IOFinalizer
txnCursRef),
             rf :: ReadLMDBFixed_ emode k v
rf@ReadLMDBFixed_ {r_db :: forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> Database emode
r_db = Database (Environment !Ptr MDB_env
penv !(TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) !MDB_dbi_t
dbi}
             ) ->
              IO
  (Step
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
     (k, v))
-> m (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Step
      ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
       ReadLMDBFixed_ emode k v)
      (k, v))
 -> m (Step
         ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
          ReadLMDBFixed_ emode k v)
         (k, v)))
-> IO
     (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
-> m (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall a b. (a -> b) -> a -> b
$ do
                let (TMVarS NumReaders
numReadersT, WriteLock
_, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars

                if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
                  then do
                    -- + pk and pv now contain the data we want to yield; prepare p and v for
                    --   yielding.
                    -- + Note: pk will remain important below in the case where the desired maximum
                    --   ChunkSize is exceeded.
                    -- + (Avoiding the extra byte size things in the non-ChunkBytes cases seemed to
                    --   improve performance by around 10 ns/pair.)
                    -- + (These bang patterns and/or the below bang pattern seemed to improve
                    --   performance by around 20 ns/pair.)
                    (!k
k, !v
v, !Int
chunkSz') <-
                      if ReadLMDBFixed_ emode k v
rf.r_chunkSzInc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
                        then do
                          (Int
kSz, k
k) <-
                            Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek ReadLMDBFixed_ emode k v
rf.r_pk IO MDB_val -> (MDB_val -> IO (Int, k)) -> IO (Int, k)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x ->
                              let sz :: Int
sz = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size in (Int
sz,) (k -> (Int, k)) -> IO k -> IO (Int, k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadLMDBFixed_ emode k v
rf.r_kmap (MDB_val
x.mv_data, Int
sz)
                          (Int
vSz, v
v) <-
                            Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek ReadLMDBFixed_ emode k v
rf.r_pv IO MDB_val -> (MDB_val -> IO (Int, v)) -> IO (Int, v)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x ->
                              let sz :: Int
sz = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size in (Int
sz,) (v -> (Int, v)) -> IO v -> IO (Int, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadLMDBFixed_ emode k v
rf.r_vmap (MDB_val
x.mv_data, Int
sz)
                          (k, v, Int) -> IO (k, v, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, v
v, Int
chunkSz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kSz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
vSz)
                        else do
                          k
k <- Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek ReadLMDBFixed_ emode k v
rf.r_pk IO MDB_val -> (MDB_val -> IO k) -> IO k
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x -> ReadLMDBFixed_ emode k v
rf.r_kmap (MDB_val
x.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size)
                          v
v <- Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek ReadLMDBFixed_ emode k v
rf.r_pv IO MDB_val -> (MDB_val -> IO v) -> IO v
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x -> ReadLMDBFixed_ emode k v
rf.r_vmap (MDB_val
x.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size)
                          (k, v, Int) -> IO (k, v, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, v
v, Int
chunkSz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ReadLMDBFixed_ emode k v
rf.r_chunkSzInc)

                    -- If the chunk size has exceeded a desired limit, dispose of the existing
                    -- read-only transaction and cursor and create new ones.
                    !((CInt, Int, Ptr MDB_cursor, IOFinalizer),
 ReadLMDBFixed_ emode k v)
x <-
                      if Int
chunkSz' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ReadLMDBFixed_ emode k v
rf.r_chunkSzMax
                        then do
                          -- Staying on the same chunk.
                          CInt
rc' <- ReadLMDBFixed_ emode k v
rf.r_cursor_get Ptr MDB_cursor
pcurs ReadLMDBFixed_ emode k v
rf.r_pk ReadLMDBFixed_ emode k v
rf.r_pv ReadLMDBFixed_ emode k v
rf.r_nextPrevOp
                          ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
 ReadLMDBFixed_ emode k v)
-> IO
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CInt
rc', Int
chunkSz', Ptr MDB_cursor
pcurs, IOFinalizer
txnCursRef), ReadLMDBFixed_ emode k v
rf)
                        else do
                          -- We make a copy of pk before aborting the current read-only transaction
                          -- (which makes the data in pk unavailable).
                          ByteString
prevk <-
                            Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek ReadLMDBFixed_ emode k v
rf.r_pk
                              IO MDB_val -> (MDB_val -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MDB_val
x -> CStringLen -> IO ByteString
B.packCStringLen (MDB_val
x.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
x.mv_size)
                          IOFinalizer -> IO ()
forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer IOFinalizer
txnCursRef
                          (Ptr MDB_cursor
pcurs', IOFinalizer
txnCursRef') <- ReadLMDBFixed_ emode k v
rf.r_newtxncurs Ptr MDB_env
penv MDB_dbi_t
dbi TMVarS NumReaders
numReadersT
                          CInt
rc' <-
                            (Ptr MDB_cursor
 -> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt)
-> ReadStart
-> Ptr MDB_cursor
-> Ptr MDB_val
-> Ptr MDB_val
-> IO CInt
positionCurs
                              ReadLMDBFixed_ emode k v
rf.r_cursor_get
                              (ReadLMDBFixed_ emode k v
rf.r_nextChunkOp ByteString
prevk)
                              Ptr MDB_cursor
pcurs'
                              ReadLMDBFixed_ emode k v
rf.r_pk
                              ReadLMDBFixed_ emode k v
rf.r_pv
                          ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
 ReadLMDBFixed_ emode k v)
-> IO
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CInt
rc', Int
0, Ptr MDB_cursor
pcurs', IOFinalizer
txnCursRef'), ReadLMDBFixed_ emode k v
rf)

                    Step
  ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
   ReadLMDBFixed_ emode k v)
  (k, v)
-> IO
     (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
    ReadLMDBFixed_ emode k v)
   (k, v)
 -> IO
      (Step
         ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
          ReadLMDBFixed_ emode k v)
         (k, v)))
-> Step
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
     (k, v)
-> IO
     (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall a b. (a -> b) -> a -> b
$ (k, v)
-> ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
    ReadLMDBFixed_ emode k v)
-> Step
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
     (k, v)
forall s a. a -> s -> Step s a
U.Yield (k
k, v
v) ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
 ReadLMDBFixed_ emode k v)
x
                  else
                    if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
mdb_notfound
                      then do
                        IOFinalizer -> IO ()
forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer IOFinalizer
txnCursRef IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOFinalizer -> IO ()
forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer ReadLMDBFixed_ emode k v
rf.r_pref
                        Step
  ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
   ReadLMDBFixed_ emode k v)
  (k, v)
-> IO
     (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Step
  ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
   ReadLMDBFixed_ emode k v)
  (k, v)
forall s a. Step s a
U.Stop
                      else do
                        IOFinalizer -> IO ()
forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer IOFinalizer
txnCursRef IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOFinalizer -> IO ()
forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer ReadLMDBFixed_ emode k v
rf.r_pref
                        String
-> CInt
-> IO
     (Step
        ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
         ReadLMDBFixed_ emode k v)
        (k, v))
forall noReturn. String -> CInt -> IO noReturn
throwLMDBErrNum String
"mdb_cursor_get" CInt
rc
        )
        ( \(ReadOptions
ropts, UseUnsafeFFI
us, db :: Database emode
db@(Database (Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) MDB_dbi_t
dbi), EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs, CStringLen -> IO k
kmap, CStringLen -> IO v
vmap) ->
            IO
  ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
   ReadLMDBFixed_ emode k v)
-> m ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
    ReadLMDBFixed_ emode k v)
 -> m ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
       ReadLMDBFixed_ emode k v))
-> IO
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
-> m ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
forall a b. (a -> b) -> a -> b
$ do
              let useInternalTxnCurs :: Bool
useInternalTxnCurs = case EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs of
                    LeftTxn Maybe ChunkSize
_ -> Bool
True
                    RightTxn (Transaction tmode emode, Cursor)
_ -> Bool
False

              -- Type-level guarantee.
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
useInternalTxnCurs Bool -> Bool -> Bool
&& Bool -> Bool
not (forall emode. Mode emode => Bool
isReadOnlyEnvironment @tmode)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"unreachable"

              case EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs of
                LeftTxn Maybe ChunkSize
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                RightTxn (Transaction tmode emode, Cursor)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                LeftTxn (Just (ChunkNumPairs Int
maxPairs)) ->
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
maxPairs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"readLMDB" String
"please specify positive ChunkNumPairs"
                LeftTxn (Just (ChunkBytes Int
maxBytes)) ->
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
maxBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"readLMDB" String
"please specify positive ChunkBytes"

              (Ptr MDB_val
pk, Ptr MDB_val
pv, IOFinalizer
pref) <- IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
-> IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
 -> IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer))
-> IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
-> IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
forall a b. (a -> b) -> a -> b
$ do
                Ptr MDB_val
pk <- IO (Ptr MDB_val)
forall a. Storable a => IO (Ptr a)
malloc
                Ptr MDB_val
pv <- IO (Ptr MDB_val) -> IO () -> IO (Ptr MDB_val)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException IO (Ptr MDB_val)
forall a. Storable a => IO (Ptr a)
malloc (Ptr MDB_val -> IO ()
forall a. Ptr a -> IO ()
free Ptr MDB_val
pk)
                IOFinalizer
pref <- IO IOFinalizer -> IO () -> IO IOFinalizer
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException (IO () -> IO IOFinalizer
forall (m :: * -> *) a. MonadIO m => IO a -> m IOFinalizer
newIOFinalizer (IO () -> IO IOFinalizer) -> IO () -> IO IOFinalizer
forall a b. (a -> b) -> a -> b
$ Ptr MDB_val -> IO ()
forall a. Ptr a -> IO ()
free Ptr MDB_val
pv IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr MDB_val -> IO ()
forall a. Ptr a -> IO ()
free Ptr MDB_val
pk) (Ptr MDB_val -> IO ()
forall a. Ptr a -> IO ()
free Ptr MDB_val
pv IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr MDB_val -> IO ()
forall a. Ptr a -> IO ()
free Ptr MDB_val
pk)
                (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
-> IO (Ptr MDB_val, Ptr MDB_val, IOFinalizer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr MDB_val
pk, Ptr MDB_val
pv, IOFinalizer
pref)

              let (TMVarS NumReaders
numReadersT, WriteLock
_, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
                  Int
chunkSz :: Int = Int
0

                  -- + Avoid case lookups in each iteration.
                  -- + (This seemed to improve performance by over 200 ns/pair.)
                  (MDB_dbi_t
nextPrevOp, ByteString -> ReadStart
nextChunkOp) = case ReadOptions
ropts.readDirection of
                    ReadDirection
Forward -> (MDB_dbi_t
mdb_next, ByteString -> ReadStart
ReadGT)
                    ReadDirection
Backward -> (MDB_dbi_t
mdb_prev, ByteString -> ReadStart
ReadLT)
                  (Int
chunkSzInc, Int
chunkSzMax) :: (Int, Int) = case EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs of
                    -- chunkSz stays zero.
                    LeftTxn Maybe ChunkSize
Nothing -> (Int
0, Int
forall a. Bounded a => a
maxBound)
                    RightTxn (Transaction tmode emode, Cursor)
_ -> (Int
0, Int
forall a. Bounded a => a
maxBound)
                    -- chunkSz increments by 1.
                    LeftTxn (Just (ChunkNumPairs Int
maxPairs)) -> (Int
1, Int
maxPairs)
                    -- “chunkSzInc > 1” means we should increment by bytes. (2 is meaningless.)
                    LeftTxn (Just (ChunkBytes Int
maxBytes)) -> (Int
2, Int
maxBytes)

                  (Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
txn_begin, Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
cursor_open, Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get, Ptr MDB_cursor -> IO ()
cursor_close, Ptr MDB_txn -> IO ()
txn_abort) =
                    case UseUnsafeFFI
us of
                      UseUnsafeFFI Bool
True ->
                        ( Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin_unsafe,
                          Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
mdb_cursor_open_unsafe,
                          Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
c_mdb_cursor_get_unsafe,
                          Ptr MDB_cursor -> IO ()
c_mdb_cursor_close_unsafe,
                          Ptr MDB_txn -> IO ()
c_mdb_txn_abort_unsafe
                        )
                      UseUnsafeFFI Bool
False ->
                        ( Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin,
                          Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
mdb_cursor_open,
                          Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
c_mdb_cursor_get,
                          Ptr MDB_cursor -> IO ()
c_mdb_cursor_close,
                          Ptr MDB_txn -> IO ()
c_mdb_txn_abort
                        )

                  newtxncurs :: Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
newtxncurs = (Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn))
-> (Ptr MDB_txn -> IO ())
-> (Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor))
-> (Ptr MDB_cursor -> IO ())
-> Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
newTxnCurs Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
txn_begin Ptr MDB_txn -> IO ()
txn_abort Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
cursor_open Ptr MDB_cursor -> IO ()
cursor_close

              (Ptr MDB_cursor
pcurs, IOFinalizer
txnCursRef) <- case EitherTxn tmode (Maybe ChunkSize) (Transaction tmode emode, Cursor)
etxncurs of
                LeftTxn Maybe ChunkSize
_ -> do
                  -- Create first transaction and cursor.
                  Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
newtxncurs Ptr MDB_env
penv MDB_dbi_t
dbi TMVarS NumReaders
numReadersT
                RightTxn (Transaction tmode emode
_, Cursor Ptr MDB_cursor
pcurs) -> do
                  -- Transaction and cursor are provided by the user.
                  IOFinalizer
f <- IO () -> IO IOFinalizer
forall (m :: * -> *) a. MonadIO m => IO a -> m IOFinalizer
newIOFinalizer (IO () -> IO IOFinalizer) -> IO () -> IO IOFinalizer
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  (Ptr MDB_cursor, IOFinalizer) -> IO (Ptr MDB_cursor, IOFinalizer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr MDB_cursor
pcurs, IOFinalizer
f)

              CInt
rc <- (Ptr MDB_cursor
 -> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt)
-> ReadStart
-> Ptr MDB_cursor
-> Ptr MDB_val
-> Ptr MDB_val
-> IO CInt
positionCurs Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get ReadOptions
ropts.readStart Ptr MDB_cursor
pcurs Ptr MDB_val
pk Ptr MDB_val
pv

              ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
 ReadLMDBFixed_ emode k v)
-> IO
     ((CInt, Int, Ptr MDB_cursor, IOFinalizer),
      ReadLMDBFixed_ emode k v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                ( -- State that can change in iterations.
                  (CInt
rc, Int
chunkSz, Ptr MDB_cursor
pcurs, IOFinalizer
txnCursRef),
                  ReadLMDBFixed_
                    { r_db :: Database emode
r_db = Database emode
db,
                      r_kmap :: CStringLen -> IO k
r_kmap = CStringLen -> IO k
kmap,
                      r_vmap :: CStringLen -> IO v
r_vmap = CStringLen -> IO v
vmap,
                      r_newtxncurs :: Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
r_newtxncurs = Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
newtxncurs,
                      r_cursor_get :: Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
r_cursor_get = Ptr MDB_cursor
-> Ptr MDB_val -> Ptr MDB_val -> MDB_dbi_t -> IO CInt
cursor_get,
                      r_nextPrevOp :: MDB_dbi_t
r_nextPrevOp = MDB_dbi_t
nextPrevOp,
                      r_nextChunkOp :: ByteString -> ReadStart
r_nextChunkOp = ByteString -> ReadStart
nextChunkOp,
                      r_chunkSzInc :: Int
r_chunkSzInc = Int
chunkSzInc,
                      r_chunkSzMax :: Int
r_chunkSzMax = Int
chunkSzMax,
                      r_pk :: Ptr MDB_val
r_pk = Ptr MDB_val
pk,
                      r_pv :: Ptr MDB_val
r_pv = Ptr MDB_val
pv,
                      r_pref :: IOFinalizer
r_pref = IOFinalizer
pref
                    }
                )
        )

-- | State that stays fixed in 'readLMDB' iterations.
--
-- /Internal/.
data ReadLMDBFixed_ emode k v = ReadLMDBFixed_
  { -- (Keeping the records lazy seemed to improve performance by around 5-10 ns/pair.)
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> Database emode
r_db :: Database emode,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> CStringLen -> IO k
r_kmap :: CStringLen -> IO k,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> CStringLen -> IO v
r_vmap :: CStringLen -> IO v,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v
-> Ptr MDB_env
-> MDB_dbi_t
-> TMVarS NumReaders
-> IO (Ptr MDB_cursor, IOFinalizer)
r_newtxncurs ::
      Ptr MDB_env ->
      MDB_dbi_t ->
      TMVarS NumReaders ->
      IO (Ptr MDB_cursor, IOFinalizer),
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v
-> Ptr MDB_cursor
-> Ptr MDB_val
-> Ptr MDB_val
-> MDB_dbi_t
-> IO CInt
r_cursor_get ::
      Ptr MDB_cursor ->
      Ptr MDB_val ->
      Ptr MDB_val ->
      MDB_cursor_op_t ->
      IO CInt,
    forall {k} (emode :: k) k v. ReadLMDBFixed_ emode k v -> MDB_dbi_t
r_nextPrevOp :: MDB_cursor_op_t,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> ByteString -> ReadStart
r_nextChunkOp :: ByteString -> ReadStart,
    forall {k} (emode :: k) k v. ReadLMDBFixed_ emode k v -> Int
r_chunkSzInc :: Int,
    forall {k} (emode :: k) k v. ReadLMDBFixed_ emode k v -> Int
r_chunkSzMax :: Int,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> Ptr MDB_val
r_pk :: Ptr MDB_val,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> Ptr MDB_val
r_pv :: Ptr MDB_val,
    forall {k} (emode :: k) k v.
ReadLMDBFixed_ emode k v -> IOFinalizer
r_pref :: IOFinalizer
  }

-- | Looks up the value for the given key in the given database.
--
-- If an existing transaction is not provided, a read-only transaction is automatically created
-- internally.
--
-- Runtime consideration: If you call 'getLMDB' very frequently without a precreated transaction,
-- you might find upon profiling that a significant time is being spent at @mdb_txn_begin@, or find
-- yourself having to increase 'maxReaders' in the environment’s limits because the transactions are
-- not being garbage collected fast enough. In this case, please consider precreating a transaction.
{-# INLINE getLMDB #-}
getLMDB ::
  forall emode tmode.
  (Mode emode, Mode tmode, SubMode emode tmode) =>
  Database emode ->
  MaybeTxn tmode (Transaction tmode emode) ->
  ByteString ->
  IO (Maybe ByteString)
getLMDB :: forall emode tmode.
(Mode emode, Mode tmode, SubMode emode tmode) =>
Database emode
-> MaybeTxn tmode (Transaction tmode emode)
-> ByteString
-> IO (Maybe ByteString)
getLMDB (Database env :: Environment emode
env@(Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
_) MDB_dbi_t
dbi) MaybeTxn tmode (Transaction tmode emode)
mtxn ByteString
k =
  let {-# INLINE brack #-}
      brack :: (Ptr MDB_txn -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
brack Ptr MDB_txn -> IO (Maybe ByteString)
io = case MaybeTxn tmode (Transaction tmode emode)
mtxn of
        MaybeTxn tmode (Transaction tmode emode)
NoTxn -> Environment emode
-> (Transaction ReadOnly emode -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall (m :: * -> *) a emode.
(Mode emode, MonadBaseControl IO m, MonadIO m) =>
Environment emode -> (Transaction ReadOnly emode -> m a) -> m a
withReadOnlyTransaction Environment emode
env ((Transaction ReadOnly emode -> IO (Maybe ByteString))
 -> IO (Maybe ByteString))
-> (Transaction ReadOnly emode -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \(Transaction Environment emode
_ Ptr MDB_txn
ptxn) -> Ptr MDB_txn -> IO (Maybe ByteString)
io Ptr MDB_txn
ptxn
        JustTxn (Transaction Environment emode
_ Ptr MDB_txn
ptxn) -> Ptr MDB_txn -> IO (Maybe ByteString)
io Ptr MDB_txn
ptxn
   in ByteString
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) ->
        MDB_val
-> (Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp) ((Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr MDB_val
pk -> (Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr MDB_val -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr MDB_val
pv ->
          (Ptr MDB_txn -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
brack ((Ptr MDB_txn -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr MDB_txn -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr MDB_txn
ptxn -> do
            CInt
rc <- Ptr MDB_txn -> MDB_dbi_t -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
c_mdb_get Ptr MDB_txn
ptxn MDB_dbi_t
dbi Ptr MDB_val
pk Ptr MDB_val
pv
            if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
              then do
                MDB_val
v' <- Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek Ptr MDB_val
pv
                ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO ByteString
B.packCStringLen (MDB_val
v'.mv_data, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MDB_val
v'.mv_size)
              else
                if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
mdb_notfound
                  then Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
                  else String -> CInt -> IO (Maybe ByteString)
forall noReturn. String -> CInt -> IO noReturn
throwLMDBErrNum String
"mdb_get" CInt
rc

-- | A read-only (@tmode@: 'ReadOnly') or read-write (@tmode@: 'ReadWrite') transaction.
--
-- @emode@: the environment’s mode. Note: 'ReadOnly' environments can only have 'ReadOnly'
-- transactions; we enforce this at the type level.
data Transaction tmode emode = Transaction !(Environment emode) !(Ptr MDB_txn)

-- | Begins an LMDB read-only transaction on the given environment.
--
-- For read-only transactions returned from this function, it is your responsibility to (a) make
-- sure the transaction only gets used by a single 'readLMDB', 'unsafeReadLMDB', or 'getLMDB' at the
-- same time, (b) use the transaction only on databases in the environment on which the transaction
-- was begun, (c) make sure that those databases were already obtained before the transaction was
-- begun, (d) dispose of the transaction with 'abortReadOnlyTransaction', and (e) be aware of the
-- caveats regarding long-lived transactions; see [Transactions](#g:transactions).
--
-- To easily manage a read-only transaction’s lifecycle, we suggest using 'withReadOnlyTransaction'.
{-# INLINE beginReadOnlyTransaction #-}
beginReadOnlyTransaction ::
  forall emode.
  (Mode emode) =>
  Environment emode ->
  IO (Transaction ReadOnly emode)
beginReadOnlyTransaction :: forall emode.
Mode emode =>
Environment emode -> IO (Transaction ReadOnly emode)
beginReadOnlyTransaction env :: Environment emode
env@(Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) = IO (Transaction ReadOnly emode) -> IO (Transaction ReadOnly emode)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Transaction ReadOnly emode)
 -> IO (Transaction ReadOnly emode))
-> IO (Transaction ReadOnly emode)
-> IO (Transaction ReadOnly emode)
forall a b. (a -> b) -> a -> b
$ do
  -- The non-concurrency requirement:
  -- https://github.com/LMDB/lmdb/blob/mdb.master/libraries/liblmdb/lmdb.h#L614
  let (TMVarS NumReaders
numReadersT, WriteLock
_, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars

  -- Similar comments for NumReaders as in unsafeReadLMDB.
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    NumReaders
n <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
    TMVarS NumReaders -> NumReaders -> STM ()
forall a. TMVarS a -> a -> STM ()
putTMVarS TMVarS NumReaders
numReadersT (NumReaders -> STM ()) -> NumReaders -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
n NumReaders -> NumReaders -> NumReaders
forall a. Num a => a -> a -> a
+ NumReaders
1

  IO (Transaction ReadOnly emode)
-> IO () -> IO (Transaction ReadOnly emode)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
    (forall tmode emode.
Environment emode -> Ptr MDB_txn -> Transaction tmode emode
forall {k} {k} (tmode :: k) (emode :: k).
Environment emode -> Ptr MDB_txn -> Transaction tmode emode
Transaction @ReadOnly Environment emode
env (Ptr MDB_txn -> Transaction ReadOnly emode)
-> IO (Ptr MDB_txn) -> IO (Transaction ReadOnly emode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
mdb_rdonly)
    ( STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        NumReaders
n <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
        TMVarS NumReaders -> NumReaders -> STM ()
forall a. TMVarS a -> a -> STM ()
putTMVarS TMVarS NumReaders
numReadersT (NumReaders -> STM ()) -> NumReaders -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
n NumReaders -> NumReaders -> NumReaders
forall a. Num a => a -> a -> a
- NumReaders
1
    )

-- | Disposes of a read-only transaction created with 'beginReadOnlyTransaction'.
--
-- It is your responsibility to not use the transaction or any of its cursors afterwards.
{-# INLINE abortReadOnlyTransaction #-}
abortReadOnlyTransaction :: forall emode. (Mode emode) => Transaction ReadOnly emode -> IO ()
abortReadOnlyTransaction :: forall emode. Mode emode => Transaction ReadOnly emode -> IO ()
abortReadOnlyTransaction (Transaction (Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) Ptr MDB_txn
ptxn) = IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let (TMVarS NumReaders
numReadersT, WriteLock
_, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn
  -- Similar comments for NumReaders as in unsafeReadLMDB.
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    NumReaders
n <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
    TMVarS NumReaders -> NumReaders -> STM ()
forall a. TMVarS a -> a -> STM ()
putTMVarS TMVarS NumReaders
numReadersT (NumReaders -> STM ()) -> NumReaders -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
n NumReaders -> NumReaders -> NumReaders
forall a. Num a => a -> a -> a
- NumReaders
1

-- | Creates a temporary read-only transaction on which the provided action is performed, after
-- which the transaction gets aborted. The transaction also gets aborted upon exceptions.
--
-- You have the same responsibilities as documented for 'beginReadOnlyTransaction' (apart from the
-- transaction disposal).
{-# INLINE withReadOnlyTransaction #-}
withReadOnlyTransaction ::
  forall m a emode.
  (Mode emode, MonadBaseControl IO m, MonadIO m) =>
  Environment emode ->
  (Transaction ReadOnly emode -> m a) ->
  m a
withReadOnlyTransaction :: forall (m :: * -> *) a emode.
(Mode emode, MonadBaseControl IO m, MonadIO m) =>
Environment emode -> (Transaction ReadOnly emode -> m a) -> m a
withReadOnlyTransaction Environment emode
env =
  m (Transaction ReadOnly emode)
-> (Transaction ReadOnly emode -> m ())
-> (Transaction ReadOnly emode -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
LI.bracket
    (IO (Transaction ReadOnly emode) -> m (Transaction ReadOnly emode)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transaction ReadOnly emode) -> m (Transaction ReadOnly emode))
-> IO (Transaction ReadOnly emode)
-> m (Transaction ReadOnly emode)
forall a b. (a -> b) -> a -> b
$ Environment emode -> IO (Transaction ReadOnly emode)
forall emode.
Mode emode =>
Environment emode -> IO (Transaction ReadOnly emode)
beginReadOnlyTransaction Environment emode
env)
    -- Aborting a transaction should never fail (as it merely frees a pointer), so any potential
    -- issues solved by safe-exceptions (in particular “swallowing asynchronous exceptions via
    -- failing cleanup handlers”) shouldn’t apply here.
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Transaction ReadOnly emode -> IO ())
-> Transaction ReadOnly emode
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction ReadOnly emode -> IO ()
forall emode. Mode emode => Transaction ReadOnly emode -> IO ()
abortReadOnlyTransaction)

-- | A cursor.
newtype Cursor = Cursor (Ptr MDB_cursor)

-- | Opens a cursor for use with 'readLMDB' or 'unsafeReadLMDB'. It is your responsibility to (a)
-- make sure the cursor only gets used by a single 'readLMDB' or 'unsafeReadLMDB' at the same time,
-- (b) make sure the provided database is within the environment on which the provided transaction
-- was begun, and (c) dispose of the cursor with 'closeCursor'.
--
-- To easily manage a cursor’s lifecycle, we suggest using 'withCursor'.
{-# INLINE openCursor #-}
openCursor ::
  forall emode tmode.
  (Mode emode, Mode tmode, SubMode emode tmode) =>
  Transaction tmode emode ->
  Database emode ->
  IO Cursor
openCursor :: forall emode tmode.
(Mode emode, Mode tmode, SubMode emode tmode) =>
Transaction tmode emode -> Database emode -> IO Cursor
openCursor (Transaction Environment emode
_ Ptr MDB_txn
ptxn) (Database Environment emode
_ MDB_dbi_t
dbi) =
  Ptr MDB_cursor -> Cursor
Cursor (Ptr MDB_cursor -> Cursor) -> IO (Ptr MDB_cursor) -> IO Cursor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MDB_txn -> MDB_dbi_t -> IO (Ptr MDB_cursor)
mdb_cursor_open Ptr MDB_txn
ptxn MDB_dbi_t
dbi

-- | Disposes of a cursor created with 'openCursor'.
{-# INLINE closeCursor #-}
closeCursor :: Cursor -> IO ()
closeCursor :: Cursor -> IO ()
closeCursor (Cursor Ptr MDB_cursor
pcurs) =
  -- (Sidenote: Although a cursor will, at least for users who use brackets, usually be called
  -- before the transaction gets aborted (read-only/read-write) or committed (read-write), the order
  -- doesn’t really matter for read-only transactions.)
  Ptr MDB_cursor -> IO ()
c_mdb_cursor_close Ptr MDB_cursor
pcurs

-- | Creates a temporary cursor on which the provided action is performed, after which the cursor
-- gets closed. The cursor also gets closed upon exceptions.
--
-- You have the same responsibilities as documented for 'openCursor' (apart from the cursor
-- disposal).
{-# INLINE withCursor #-}
withCursor ::
  forall m a emode tmode.
  (MonadBaseControl IO m, MonadIO m, Mode emode, Mode tmode, SubMode emode tmode) =>
  Transaction tmode emode ->
  Database emode ->
  (Cursor -> m a) ->
  m a
withCursor :: forall (m :: * -> *) a emode tmode.
(MonadBaseControl IO m, MonadIO m, Mode emode, Mode tmode,
 SubMode emode tmode) =>
Transaction tmode emode -> Database emode -> (Cursor -> m a) -> m a
withCursor Transaction tmode emode
txn Database emode
db =
  m Cursor -> (Cursor -> m ()) -> (Cursor -> m a) -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
LI.bracket
    (IO Cursor -> m Cursor
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Cursor -> m Cursor) -> IO Cursor -> m Cursor
forall a b. (a -> b) -> a -> b
$ Transaction tmode emode -> Database emode -> IO Cursor
forall emode tmode.
(Mode emode, Mode tmode, SubMode emode tmode) =>
Transaction tmode emode -> Database emode -> IO Cursor
openCursor Transaction tmode emode
txn Database emode
db)
    -- Closing a cursor should never fail (as it merely frees a pointer), so any potential issues
    -- solved by safe-exceptions (in particular “swallowing asynchronous exceptions via failing
    -- cleanup handlers”) shouldn’t apply here.
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Cursor -> IO ()) -> Cursor -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> IO ()
closeCursor)

data ReadOptions = ReadOptions
  -- It might seem strange to allow, e.g., ReadBeg and Backward together. However, this simplifies
  -- things in the sense that it separates the initial position concept from the iteration
  -- (next/prev) concept.
  { ReadOptions -> ReadStart
readStart :: !ReadStart,
    ReadOptions -> ReadDirection
readDirection :: !ReadDirection
  }
  deriving (Int -> ReadOptions -> String -> String
[ReadOptions] -> String -> String
ReadOptions -> String
(Int -> ReadOptions -> String -> String)
-> (ReadOptions -> String)
-> ([ReadOptions] -> String -> String)
-> Show ReadOptions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReadOptions -> String -> String
showsPrec :: Int -> ReadOptions -> String -> String
$cshow :: ReadOptions -> String
show :: ReadOptions -> String
$cshowList :: [ReadOptions] -> String -> String
showList :: [ReadOptions] -> String -> String
Show)

-- | By default, we start reading from the beginning of the database (i.e., from the smallest key)
-- and iterate in forward direction.
defaultReadOptions :: ReadOptions
defaultReadOptions :: ReadOptions
defaultReadOptions =
  ReadOptions
    { readStart :: ReadStart
readStart = ReadStart
ReadBeg,
      readDirection :: ReadDirection
readDirection = ReadDirection
Forward
    }

-- | Direction of key iteration.
data ReadDirection = Forward | Backward deriving (Int -> ReadDirection -> String -> String
[ReadDirection] -> String -> String
ReadDirection -> String
(Int -> ReadDirection -> String -> String)
-> (ReadDirection -> String)
-> ([ReadDirection] -> String -> String)
-> Show ReadDirection
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReadDirection -> String -> String
showsPrec :: Int -> ReadDirection -> String -> String
$cshow :: ReadDirection -> String
show :: ReadDirection -> String
$cshowList :: [ReadDirection] -> String -> String
showList :: [ReadDirection] -> String -> String
Show)

-- | The key from which an iteration should start.
data ReadStart
  = -- | Start from the smallest key.
    ReadBeg
  | -- | Start from the largest key.
    ReadEnd
  | -- | Start from the smallest key that is greater than or equal to the given key.
    ReadGE !ByteString
  | -- | Start from the smallest key that is greater than the given key.
    ReadGT !ByteString
  | -- | Start from the largest key that is less than or equal to the given key.
    ReadLE !ByteString
  | -- | Start from the largest key that is less than the given key.
    ReadLT !ByteString
  deriving (Int -> ReadStart -> String -> String
[ReadStart] -> String -> String
ReadStart -> String
(Int -> ReadStart -> String -> String)
-> (ReadStart -> String)
-> ([ReadStart] -> String -> String)
-> Show ReadStart
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReadStart -> String -> String
showsPrec :: Int -> ReadStart -> String -> String
$cshow :: ReadStart -> String
show :: ReadStart -> String
$cshowList :: [ReadStart] -> String -> String
showList :: [ReadStart] -> String -> String
Show)

-- | Begins an LMDB read-write transaction on the given environment.
--
-- Unlike read-only transactions, a given read-write transaction is not allowed to stray from the OS
-- thread on which it was begun, and it is your responsibility to make sure of this. You can achieve
-- this with, e.g., 'Control.Concurrent.runInBoundThread'.
--
-- Additionally, for read-write transactions returned from this function, it is your responsibility
-- to (a) use the transaction only on databases in the environment on which the transaction was
-- begun, (b) make sure that those databases were already obtained before the transaction was begun,
-- (c) commit\/abort the transaction with 'commitReadWriteTransaction'\/'abortReadWriteTransaction',
-- and (d) be aware of the caveats regarding long-lived transactions; see
-- [Transactions](#g:transactions).
--
-- To easily manage a read-write transaction’s lifecycle, we suggest using
-- 'withReadWriteTransaction'.
{-# INLINE beginReadWriteTransaction #-}
beginReadWriteTransaction :: Environment ReadWrite -> IO (Transaction ReadWrite ReadWrite)
beginReadWriteTransaction :: Environment ReadWrite -> IO (Transaction ReadWrite ReadWrite)
beginReadWriteTransaction env :: Environment ReadWrite
env@(Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) = IO (Transaction ReadWrite ReadWrite)
-> IO (Transaction ReadWrite ReadWrite)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Transaction ReadWrite ReadWrite)
 -> IO (Transaction ReadWrite ReadWrite))
-> IO (Transaction ReadWrite ReadWrite)
-> IO (Transaction ReadWrite ReadWrite)
forall a b. (a -> b) -> a -> b
$ do
  IO Bool
isCurrentThreadBound
    IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      (String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"beginReadWriteTransaction" String
"please call on a bound thread")
  ThreadId
threadId <- IO ThreadId
myThreadId

  let (TMVarS NumReaders
_, WriteLock MVar ()
lock, WriteThread MVar ThreadId
writeThread, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock () -- Interruptible when waiting for other read-write transactions.
  MVar ThreadId -> ThreadId -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ThreadId
writeThread ThreadId
threadId IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> IO ()
forall a. HasCallStack => String -> a
error String
"unreachable")
  let disclaimWriteOwnership :: IO (Maybe ())
disclaimWriteOwnership = IO (Maybe ()) -> IO (Maybe ())
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Maybe ()) -> IO (Maybe ())) -> IO (Maybe ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ MVar ThreadId -> IO (Maybe ThreadId)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
writeThread IO (Maybe ThreadId) -> IO (Maybe ()) -> IO (Maybe ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
lock

  IO (Transaction ReadWrite ReadWrite)
-> IO (Maybe ()) -> IO (Transaction ReadWrite ReadWrite)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
    (forall tmode emode.
Environment emode -> Ptr MDB_txn -> Transaction tmode emode
forall {k} {k} (tmode :: k) (emode :: k).
Environment emode -> Ptr MDB_txn -> Transaction tmode emode
Transaction @ReadWrite Environment ReadWrite
env (Ptr MDB_txn -> Transaction ReadWrite ReadWrite)
-> IO (Ptr MDB_txn) -> IO (Transaction ReadWrite ReadWrite)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
0)
    IO (Maybe ())
disclaimWriteOwnership

-- | Aborts a read-write transaction created with 'beginReadWriteTransaction'.
--
-- It is your responsibility to not use the transaction afterwards.
{-# INLINE abortReadWriteTransaction #-}
abortReadWriteTransaction :: Transaction ReadWrite ReadWrite -> IO ()
abortReadWriteTransaction :: Transaction ReadWrite ReadWrite -> IO ()
abortReadWriteTransaction (Transaction (Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) Ptr MDB_txn
ptxn) = IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let throwErr :: String -> m a
throwErr = String -> String -> m a
forall (m :: * -> *) a. String -> String -> m a
throwError String
"abortReadWriteTransaction"
  let (TMVarS NumReaders
_, WriteLock MVar ()
lock, WriteThread MVar ThreadId
writeThread, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  Bool -> MVar ThreadId -> (String -> IO ()) -> IO ()
detectUserErrors Bool
True MVar ThreadId
writeThread String -> IO ()
forall {m :: * -> *} {a}. String -> m a
throwErr
  Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn
  IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
lock

-- | Commits a read-write transaction created with 'beginReadWriteTransaction'.
--
-- It is your responsibility to not use the transaction afterwards.
{-# INLINE commitReadWriteTransaction #-}
commitReadWriteTransaction :: Transaction ReadWrite ReadWrite -> IO ()
commitReadWriteTransaction :: Transaction ReadWrite ReadWrite -> IO ()
commitReadWriteTransaction (Transaction (Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) Ptr MDB_txn
ptxn) = IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let throwErr :: String -> m a
throwErr = String -> String -> m a
forall (m :: * -> *) a. String -> String -> m a
throwError String
"commitReadWriteTransaction"
  let (TMVarS NumReaders
_, WriteLock MVar ()
lock, WriteThread MVar ThreadId
writeThread, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  Bool -> MVar ThreadId -> (String -> IO ()) -> IO ()
detectUserErrors Bool
True MVar ThreadId
writeThread String -> IO ()
forall {m :: * -> *} {a}. String -> m a
throwErr
  IO () -> IO (Maybe ()) -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
    (Ptr MDB_txn -> IO ()
mdb_txn_commit Ptr MDB_txn
ptxn)
    (Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn IO () -> IO (Maybe ()) -> IO (Maybe ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
lock)
  IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
lock

-- | Spawns a new bound thread and creates a temporary read-write transaction on which the provided
-- action is performed, after which the transaction gets committed. The transaction gets aborted
-- upon exceptions.
--
-- You have the same responsibilities as documented for 'beginReadWriteTransaction' (apart from
-- running it on a bound thread and committing/aborting it).
{-# INLINE withReadWriteTransaction #-}
withReadWriteTransaction ::
  forall m a.
  (MonadBaseControl IO m, MonadIO m) =>
  Environment ReadWrite ->
  (Transaction ReadWrite ReadWrite -> m a) ->
  m a
withReadWriteTransaction :: forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m) =>
Environment ReadWrite
-> (Transaction ReadWrite ReadWrite -> m a) -> m a
withReadWriteTransaction Environment ReadWrite
env Transaction ReadWrite ReadWrite -> m a
io =
  m a -> m a
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
LI.runInBoundThread (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    -- We need an enhanced bracket. Using the normal bracket and simply committing after running io
    -- in the “in-between” computation is incorrect because this entire “in-between” computation
    -- falls under “restore” in bracket’s implementation, so an asynchronous exception can cause a
    -- commit to be followed by an abort. (Our 'testAsyncExceptionsConcurrent' test exposed this.)
    m (Transaction ReadWrite ReadWrite)
-> (Transaction ReadWrite ReadWrite -> m ())
-> (Transaction ReadWrite ReadWrite -> m ())
-> (Transaction ReadWrite ReadWrite -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m b) -> (a -> m c) -> m c
liftedBracket2
      (IO (Transaction ReadWrite ReadWrite)
-> m (Transaction ReadWrite ReadWrite)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transaction ReadWrite ReadWrite)
 -> m (Transaction ReadWrite ReadWrite))
-> IO (Transaction ReadWrite ReadWrite)
-> m (Transaction ReadWrite ReadWrite)
forall a b. (a -> b) -> a -> b
$ Environment ReadWrite -> IO (Transaction ReadWrite ReadWrite)
beginReadWriteTransaction Environment ReadWrite
env)
      -- + Aborting a transaction should never fail (as it merely frees a pointer), so any potential
      --   issues solved by safe-exceptions (in particular “swallowing asynchronous exceptions via
      --   failing cleanup handlers”) shouldn’t apply here.
      -- + Note: We have convinced ourselves that both the abort and commit are uninterruptible. (In
      --   particular, we presume 'myThreadId' (in 'detectUserErrors') is uninterruptible.)
      (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Transaction ReadWrite ReadWrite -> IO ())
-> Transaction ReadWrite ReadWrite
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction ReadWrite ReadWrite -> IO ()
abortReadWriteTransaction)
      (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Transaction ReadWrite ReadWrite -> IO ())
-> Transaction ReadWrite ReadWrite
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction ReadWrite ReadWrite -> IO ()
commitReadWriteTransaction)
      Transaction ReadWrite ReadWrite -> m a
io

-- |
-- * @OverwriteAllow@: When a key reoccurs, overwrite the value.
-- * @OverwriteDisallow@: When a key reoccurs, don’t overwrite and hand the maladaptive key-value
--   pair to the accumulator.
-- * @OverwriteAppend@: Assume the input data is already increasing, which allows the use of
--   @MDB_APPEND@ under the hood and substantially improves write performance. Hand arriving
--   key-value pairs in a maladaptive order to the accumulator.
data OverwriteOptions m a where
  OverwriteAllow :: OverwriteOptions m ()
  OverwriteDisallow :: Either (WriteAccum m a) (WriteAccumWithOld m a) -> OverwriteOptions m a
  OverwriteAppend :: WriteAccum m a -> OverwriteOptions m a

-- | A fold for @(key, new value)@.
type WriteAccum m a = Fold m (ByteString, ByteString) a

-- | A fold for @(key, new value, old value)@. This has the overhead of getting the old value.
type WriteAccumWithOld m a = Fold m (ByteString, ByteString, ByteString) a

newtype WriteOptions m a = WriteOptions
  { forall (m :: * -> *) a. WriteOptions m a -> OverwriteOptions m a
writeOverwriteOptions :: OverwriteOptions m a
  }

-- | A function that shows a database key.
type ShowKey = ByteString -> String

-- | A function that shows a database value.
type ShowValue = ByteString -> String

-- | Throws upon the first maladaptive key. If desired, shows the maladaptive key-value pair in the
-- exception.
{-# INLINE writeAccumThrow #-}
writeAccumThrow :: (Monad m) => Maybe (ShowKey, ShowValue) -> WriteAccum m ()
writeAccumThrow :: forall (m :: * -> *).
Monad m =>
Maybe (ShowKey, ShowKey) -> WriteAccum m ()
writeAccumThrow Maybe (ShowKey, ShowKey)
mshow =
  (() -> (ByteString, ByteString) -> m ())
-> m () -> Fold m (ByteString, ByteString) ()
forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m b) -> m b -> Fold m a b
F.foldlM'
    ( \() (ByteString
k, ByteString
v) ->
        String -> String -> m ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"writeLMDB" (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
          String
"Maladaptive key encountered"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> ((ShowKey, ShowKey) -> String)
-> Maybe (ShowKey, ShowKey)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              String
""
              (\(ShowKey
showk, ShowKey
showv) -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"; (key,value)=(%s,%s)" (ShowKey
showk ByteString
k) (ShowKey
showv ByteString
v))
              Maybe (ShowKey, ShowKey)
mshow
    )
    (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Throws upon the first maladaptive key where the old value differs from the new value. If
-- desired, shows the maladaptive key-value pair with the old value in the exception.
{-# INLINE writeAccumThrowAllowSameValue #-}
writeAccumThrowAllowSameValue :: (Monad m) => Maybe (ShowKey, ShowValue) -> WriteAccumWithOld m ()
writeAccumThrowAllowSameValue :: forall (m :: * -> *).
Monad m =>
Maybe (ShowKey, ShowKey) -> WriteAccumWithOld m ()
writeAccumThrowAllowSameValue Maybe (ShowKey, ShowKey)
mshow =
  (() -> (ByteString, ByteString, ByteString) -> m ())
-> m () -> Fold m (ByteString, ByteString, ByteString) ()
forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m b) -> m b -> Fold m a b
F.foldlM'
    ( \() (ByteString
k, ByteString
v, ByteString
oldv) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
v ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
oldv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          String -> String -> m ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"writeLMDB" (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
            String
"Maladaptive key encountered"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> ((ShowKey, ShowKey) -> String)
-> Maybe (ShowKey, ShowKey)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                String
""
                ( \(ShowKey
showk, ShowKey
showv) ->
                    String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"; (key,value,oldValue)=(%s,%s,%s)" (ShowKey
showk ByteString
k) (ShowKey
showv ByteString
v) (ShowKey
showv ByteString
oldv)
                )
                Maybe (ShowKey, ShowKey)
mshow
    )
    (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Silently ignores maladaptive keys.
{-# INLINE writeAccumIgnore #-}
writeAccumIgnore :: (Monad m) => WriteAccum m ()
writeAccumIgnore :: forall (m :: * -> *). Monad m => WriteAccum m ()
writeAccumIgnore = Fold m (ByteString, ByteString) ()
forall (m :: * -> *) a. Monad m => Fold m a ()
F.drain

-- | Gracefully stops upon the first maladaptive key.
{-# INLINE writeAccumStop #-}
writeAccumStop :: (Monad m) => WriteAccum m ()
writeAccumStop :: forall (m :: * -> *). Monad m => WriteAccum m ()
writeAccumStop = Fold m (ByteString, ByteString) (Maybe (ByteString, ByteString))
-> Fold m (ByteString, ByteString) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Fold m (ByteString, ByteString) (Maybe (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => Fold m a (Maybe a)
F.one

-- | By default, we allow overwriting.
defaultWriteOptions :: WriteOptions m ()
defaultWriteOptions :: forall (m :: * -> *). WriteOptions m ()
defaultWriteOptions =
  WriteOptions
    { writeOverwriteOptions :: OverwriteOptions m ()
writeOverwriteOptions = OverwriteOptions m ()
forall (m :: * -> *). OverwriteOptions m ()
OverwriteAllow
    }

-- | A chunk size.
data ChunkSize
  = -- | Chunk up key-value pairs by number of pairs. The final chunk can have a fewer number of
    -- pairs.
    ChunkNumPairs !Int
  | -- | Chunk up key-value pairs by number of bytes. As soon as the byte count for the keys and
    -- values is reached, a new chunk is created (such that each chunk has at least one key-value
    -- pair and can end up with more than the desired number of bytes). The final chunk can have
    -- less than the desired number of bytes.
    ChunkBytes !Int
  deriving (Int -> ChunkSize -> String -> String
[ChunkSize] -> String -> String
ChunkSize -> String
(Int -> ChunkSize -> String -> String)
-> (ChunkSize -> String)
-> ([ChunkSize] -> String -> String)
-> Show ChunkSize
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ChunkSize -> String -> String
showsPrec :: Int -> ChunkSize -> String -> String
$cshow :: ChunkSize -> String
show :: ChunkSize -> String
$cshowList :: [ChunkSize] -> String -> String
showList :: [ChunkSize] -> String -> String
Show)

-- | Chunks up the incoming stream of key-value pairs using the desired chunk size. One can try,
-- e.g., @ChunkBytes mebibyte@ (1 MiB chunks) and benchmark from there.
--
-- The chunks are processed using the desired fold.
{-# INLINE chunkPairsFold #-}
chunkPairsFold ::
  forall m a.
  (Monad m) =>
  ChunkSize ->
  Fold m (Seq (ByteString, ByteString)) a ->
  Fold m (ByteString, ByteString) a
chunkPairsFold :: forall (m :: * -> *) a.
Monad m =>
ChunkSize
-> Fold m (Seq (ByteString, ByteString)) a
-> Fold m (ByteString, ByteString) a
chunkPairsFold ChunkSize
chunkSz (F.Fold s -> Seq (ByteString, ByteString) -> m (Step s a)
astep m (Step s a)
ainit s -> m a
aextr s -> m a
afinal) =
  let {-# INLINE final #-}
      final :: Seq (ByteString, ByteString) -> s -> m a
final Seq (ByteString, ByteString)
sequ s
as =
        case Seq (ByteString, ByteString)
sequ of
          Seq (ByteString, ByteString)
Seq.Empty -> s -> m a
afinal s
as
          Seq (ByteString, ByteString)
_ -> do
            Step s a
astep' <- s -> Seq (ByteString, ByteString) -> m (Step s a)
astep s
as Seq (ByteString, ByteString)
sequ
            case Step s a
astep' of
              F.Done a
b -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
              F.Partial s
as' -> s -> m a
afinal s
as'
   in case ChunkSize
chunkSz of
        ChunkNumPairs Int
numPairs ->
          ((Seq (ByteString, ByteString), s)
 -> (ByteString, ByteString)
 -> m (Step (Seq (ByteString, ByteString), s) a))
-> m (Step (Seq (ByteString, ByteString), s) a)
-> ((Seq (ByteString, ByteString), s) -> m a)
-> ((Seq (ByteString, ByteString), s) -> m a)
-> Fold m (ByteString, ByteString) a
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold
            ( \(!Seq (ByteString, ByteString)
sequ, !s
as) (ByteString
k, ByteString
v) ->
                let sequ' :: Seq (ByteString, ByteString)
sequ' = Seq (ByteString, ByteString)
sequ Seq (ByteString, ByteString)
-> (ByteString, ByteString) -> Seq (ByteString, ByteString)
forall a. Seq a -> a -> Seq a
Seq.|> (ByteString
k, ByteString
v)
                 in if Seq (ByteString, ByteString) -> Int
forall a. Seq a -> Int
Seq.length Seq (ByteString, ByteString)
sequ' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numPairs
                      then
                        -- The (user-supplied) astep could already be Done here.
                        (s -> (Seq (ByteString, ByteString), s))
-> Step s a -> Step (Seq (ByteString, ByteString), s) a
forall a b c. (a -> b) -> Step a c -> Step b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty,) (Step s a -> Step (Seq (ByteString, ByteString), s) a)
-> m (Step s a) -> m (Step (Seq (ByteString, ByteString), s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Seq (ByteString, ByteString) -> m (Step s a)
astep s
as Seq (ByteString, ByteString)
sequ'
                      else Step (Seq (ByteString, ByteString), s) a
-> m (Step (Seq (ByteString, ByteString), s) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Seq (ByteString, ByteString), s) a
 -> m (Step (Seq (ByteString, ByteString), s) a))
-> ((Seq (ByteString, ByteString), s)
    -> Step (Seq (ByteString, ByteString), s) a)
-> (Seq (ByteString, ByteString), s)
-> m (Step (Seq (ByteString, ByteString), s) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (ByteString, ByteString), s)
-> Step (Seq (ByteString, ByteString), s) a
forall s b. s -> Step s b
F.Partial ((Seq (ByteString, ByteString), s)
 -> m (Step (Seq (ByteString, ByteString), s) a))
-> (Seq (ByteString, ByteString), s)
-> m (Step (Seq (ByteString, ByteString), s) a)
forall a b. (a -> b) -> a -> b
$ (Seq (ByteString, ByteString)
sequ', s
as)
            )
            -- The (user-supplied) ainit could already be Done here.
            ((s -> (Seq (ByteString, ByteString), s))
-> Step s a -> Step (Seq (ByteString, ByteString), s) a
forall a b c. (a -> b) -> Step a c -> Step b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty,) (Step s a -> Step (Seq (ByteString, ByteString), s) a)
-> m (Step s a) -> m (Step (Seq (ByteString, ByteString), s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Step s a)
ainit)
            -- If driven with a scan, the collection fold is assumed to also be compatible with
            -- scans and will result in the same output repeatedly for a chunk being built. (This
            -- should already be clear to the user.)
            (\(Seq (ByteString, ByteString)
_, s
as) -> s -> m a
aextr s
as)
            -- This is the only direct exit point of this outer fold (since elsewhere it yields a
            -- partial). This is therefore the only place where afinal needs to be called.
            ((Seq (ByteString, ByteString) -> s -> m a)
-> (Seq (ByteString, ByteString), s) -> m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Seq (ByteString, ByteString) -> s -> m a
final)
        ChunkBytes Int
bytes ->
          -- All the comments for the above case hold here too.
          ((Seq (ByteString, ByteString), Int, s)
 -> (ByteString, ByteString)
 -> m (Step (Seq (ByteString, ByteString), Int, s) a))
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
-> ((Seq (ByteString, ByteString), Int, s) -> m a)
-> ((Seq (ByteString, ByteString), Int, s) -> m a)
-> Fold m (ByteString, ByteString) a
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold
            ( \(!Seq (ByteString, ByteString)
sequ, !Int
byt, !s
as) (ByteString
k, ByteString
v) ->
                let sequ' :: Seq (ByteString, ByteString)
sequ' = Seq (ByteString, ByteString)
sequ Seq (ByteString, ByteString)
-> (ByteString, ByteString) -> Seq (ByteString, ByteString)
forall a. Seq a -> a -> Seq a
Seq.|> (ByteString
k, ByteString
v)
                    byt' :: Int
byt' = Int
byt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
v
                 in if Int
byt' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bytes
                      then
                        (s -> (Seq (ByteString, ByteString), Int, s))
-> Step s a -> Step (Seq (ByteString, ByteString), Int, s) a
forall a b c. (a -> b) -> Step a c -> Step b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty,Int
0,) (Step s a -> Step (Seq (ByteString, ByteString), Int, s) a)
-> m (Step s a)
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Seq (ByteString, ByteString) -> m (Step s a)
astep s
as Seq (ByteString, ByteString)
sequ'
                      else
                        -- For long streams of empty keys and values, sequ' can also get long; but
                        -- this should be expected behavior (and is an irrelevant edge case for most
                        -- users anyway).
                        Step (Seq (ByteString, ByteString), Int, s) a
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Seq (ByteString, ByteString), Int, s) a
 -> m (Step (Seq (ByteString, ByteString), Int, s) a))
-> ((Seq (ByteString, ByteString), Int, s)
    -> Step (Seq (ByteString, ByteString), Int, s) a)
-> (Seq (ByteString, ByteString), Int, s)
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (ByteString, ByteString), Int, s)
-> Step (Seq (ByteString, ByteString), Int, s) a
forall s b. s -> Step s b
F.Partial ((Seq (ByteString, ByteString), Int, s)
 -> m (Step (Seq (ByteString, ByteString), Int, s) a))
-> (Seq (ByteString, ByteString), Int, s)
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
forall a b. (a -> b) -> a -> b
$ (Seq (ByteString, ByteString)
sequ', Int
byt', s
as)
            )
            ((s -> (Seq (ByteString, ByteString), Int, s))
-> Step s a -> Step (Seq (ByteString, ByteString), Int, s) a
forall a b c. (a -> b) -> Step a c -> Step b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty,Int
0,) (Step s a -> Step (Seq (ByteString, ByteString), Int, s) a)
-> m (Step s a)
-> m (Step (Seq (ByteString, ByteString), Int, s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Step s a)
ainit)
            (\(Seq (ByteString, ByteString)
_, Int
_, s
as) -> s -> m a
aextr s
as)
            (\(Seq (ByteString, ByteString)
sequ, Int
_, s
as) -> Seq (ByteString, ByteString) -> s -> m a
final Seq (ByteString, ByteString)
sequ s
as)

-- | Chunks up the incoming stream of key-value pairs using the desired chunk size. One can try,
-- e.g., @ChunkBytes mebibyte@ (1 MiB chunks) and benchmark from there.
{-# INLINE chunkPairs #-}
chunkPairs ::
  (Monad m) =>
  ChunkSize ->
  Stream m (ByteString, ByteString) ->
  Stream m (Seq (ByteString, ByteString))
chunkPairs :: forall (m :: * -> *).
Monad m =>
ChunkSize
-> Stream m (ByteString, ByteString)
-> Stream m (Seq (ByteString, ByteString))
chunkPairs ChunkSize
chunkSz =
  Fold m (ByteString, ByteString) (Seq (ByteString, ByteString))
-> Stream m (ByteString, ByteString)
-> Stream m (Seq (ByteString, ByteString))
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> Stream m a -> Stream m b
S.foldMany (Fold m (ByteString, ByteString) (Seq (ByteString, ByteString))
 -> Stream m (ByteString, ByteString)
 -> Stream m (Seq (ByteString, ByteString)))
-> Fold m (ByteString, ByteString) (Seq (ByteString, ByteString))
-> Stream m (ByteString, ByteString)
-> Stream m (Seq (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$
    case ChunkSize
chunkSz of
      ChunkNumPairs Int
numPairs ->
        (Seq (ByteString, ByteString)
 -> (ByteString, ByteString)
 -> m (Step
         (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))))
-> m (Step
        (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString)))
-> (Seq (ByteString, ByteString)
    -> m (Seq (ByteString, ByteString)))
-> (Seq (ByteString, ByteString)
    -> m (Seq (ByteString, ByteString)))
-> Fold m (ByteString, ByteString) (Seq (ByteString, ByteString))
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold
          ( \(!Seq (ByteString, ByteString)
sequ) (ByteString
k, ByteString
v) ->
              let sequ' :: Seq (ByteString, ByteString)
sequ' = Seq (ByteString, ByteString)
sequ Seq (ByteString, ByteString)
-> (ByteString, ByteString) -> Seq (ByteString, ByteString)
forall a. Seq a -> a -> Seq a
Seq.|> (ByteString
k, ByteString
v)
               in Step (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
 -> m (Step
         (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))))
-> Step
     (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$
                    if Seq (ByteString, ByteString) -> Int
forall a. Seq a -> Int
Seq.length Seq (ByteString, ByteString)
sequ' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numPairs
                      then Seq (ByteString, ByteString)
-> Step
     (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
forall s b. b -> Step s b
F.Done Seq (ByteString, ByteString)
sequ'
                      else Seq (ByteString, ByteString)
-> Step
     (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
forall s b. s -> Step s b
F.Partial Seq (ByteString, ByteString)
sequ'
          )
          (Step (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
 -> m (Step
         (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))))
-> Step
     (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$ Seq (ByteString, ByteString)
-> Step
     (Seq (ByteString, ByteString)) (Seq (ByteString, ByteString))
forall s b. s -> Step s b
F.Partial Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty)
          (String
-> Seq (ByteString, ByteString) -> m (Seq (ByteString, ByteString))
forall a. HasCallStack => String -> a
error String
"unreachable")
          Seq (ByteString, ByteString) -> m (Seq (ByteString, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ChunkBytes Int
bytes ->
        ((Seq (ByteString, ByteString), Int)
 -> (ByteString, ByteString)
 -> m (Step
         (Seq (ByteString, ByteString), Int)
         (Seq (ByteString, ByteString))))
-> m (Step
        (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString)))
-> ((Seq (ByteString, ByteString), Int)
    -> m (Seq (ByteString, ByteString)))
-> ((Seq (ByteString, ByteString), Int)
    -> m (Seq (ByteString, ByteString)))
-> Fold m (ByteString, ByteString) (Seq (ByteString, ByteString))
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold
          ( \(!Seq (ByteString, ByteString)
sequ, !Int
byt) (ByteString
k, ByteString
v) ->
              let sequ' :: Seq (ByteString, ByteString)
sequ' = Seq (ByteString, ByteString)
sequ Seq (ByteString, ByteString)
-> (ByteString, ByteString) -> Seq (ByteString, ByteString)
forall a. Seq a -> a -> Seq a
Seq.|> (ByteString
k, ByteString
v)
                  byt' :: Int
byt' = Int
byt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
v
               in Step
  (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
 -> m (Step
         (Seq (ByteString, ByteString), Int)
         (Seq (ByteString, ByteString))))
-> Step
     (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$
                    if Int
byt' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bytes
                      then Seq (ByteString, ByteString)
-> Step
     (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
forall s b. b -> Step s b
F.Done Seq (ByteString, ByteString)
sequ'
                      else (Seq (ByteString, ByteString), Int)
-> Step
     (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
forall s b. s -> Step s b
F.Partial (Seq (ByteString, ByteString)
sequ', Int
byt')
          )
          (Step
  (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
 -> m (Step
         (Seq (ByteString, ByteString), Int)
         (Seq (ByteString, ByteString))))
-> Step
     (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
-> m (Step
        (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$ (Seq (ByteString, ByteString), Int)
-> Step
     (Seq (ByteString, ByteString), Int) (Seq (ByteString, ByteString))
forall s b. s -> Step s b
F.Partial (Seq (ByteString, ByteString)
forall a. Seq a
Seq.empty, Int
0))
          (String
-> (Seq (ByteString, ByteString), Int)
-> m (Seq (ByteString, ByteString))
forall a. HasCallStack => String -> a
error String
"unreachable")
          (\(Seq (ByteString, ByteString)
sequ, Int
_) -> Seq (ByteString, ByteString) -> m (Seq (ByteString, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Seq (ByteString, ByteString)
sequ)

-- | Writes a chunk of key-value pairs to the given database. Under the hood, it uses 'writeLMDB'
-- surrounded with a 'withReadWriteTransaction'.
{-# INLINE writeLMDBChunk #-}
writeLMDBChunk ::
  forall m a.
  (MonadBaseControl IO m, MonadIO m, MonadCatch m) =>
  WriteOptions m a ->
  Database ReadWrite ->
  Seq (ByteString, ByteString) ->
  m a
writeLMDBChunk :: forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m, MonadCatch m) =>
WriteOptions m a
-> Database ReadWrite -> Seq (ByteString, ByteString) -> m a
writeLMDBChunk =
  UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Seq (ByteString, ByteString)
-> m a
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m, MonadCatch m) =>
UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Seq (ByteString, ByteString)
-> m a
writeLMDBChunk' (Bool -> UseUnsafeFFI
UseUnsafeFFI Bool
False)

-- | Similar to 'writeLMDBChunk', except that it has an extra 'UseUnsafeFFI' parameter.
--
-- /Internal/.
{-# INLINE writeLMDBChunk' #-}
writeLMDBChunk' ::
  forall m a.
  (MonadBaseControl IO m, MonadIO m, MonadCatch m) =>
  UseUnsafeFFI ->
  WriteOptions m a ->
  Database ReadWrite ->
  Seq (ByteString, ByteString) ->
  m a
writeLMDBChunk' :: forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m, MonadCatch m) =>
UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Seq (ByteString, ByteString)
-> m a
writeLMDBChunk' UseUnsafeFFI
useUnsafeFFI WriteOptions m a
wopts db :: Database ReadWrite
db@(Database Environment ReadWrite
env MDB_dbi_t
_) Seq (ByteString, ByteString)
sequ =
  Environment ReadWrite
-> (Transaction ReadWrite ReadWrite -> m a) -> m a
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m) =>
Environment ReadWrite
-> (Transaction ReadWrite ReadWrite -> m a) -> m a
withReadWriteTransaction Environment ReadWrite
env ((Transaction ReadWrite ReadWrite -> m a) -> m a)
-> (Transaction ReadWrite ReadWrite -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Transaction ReadWrite ReadWrite
txn ->
    Fold m (ByteString, ByteString) a
-> Stream m (ByteString, ByteString) -> m a
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> Stream m a -> m b
S.fold (UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m, MonadThrow m) =>
UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
writeLMDB' UseUnsafeFFI
useUnsafeFFI WriteOptions m a
wopts Database ReadWrite
db Transaction ReadWrite ReadWrite
txn) (Stream m (ByteString, ByteString) -> m a)
-> (Seq (ByteString, ByteString)
    -> Stream m (ByteString, ByteString))
-> Seq (ByteString, ByteString)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> Stream m (ByteString, ByteString)
forall (m :: * -> *) a. Applicative m => [a] -> Stream m a
S.fromList ([(ByteString, ByteString)] -> Stream m (ByteString, ByteString))
-> (Seq (ByteString, ByteString) -> [(ByteString, ByteString)])
-> Seq (ByteString, ByteString)
-> Stream m (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (ByteString, ByteString) -> [(ByteString, ByteString)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (ByteString, ByteString) -> m a)
-> Seq (ByteString, ByteString) -> m a
forall a b. (a -> b) -> a -> b
$ Seq (ByteString, ByteString)
sequ

-- | Creates a fold that writes a stream of key-value pairs to the provided database using the
-- provided transaction.
--
-- If you have a long stream of key-value pairs that you want to write to an LMDB database while
-- avoiding a long-lived transaction (see [Transactions](#g:transactions)), you can use the
-- functions for [chunked writing](#g:chunkedwriting).
{-# INLINE writeLMDB #-}
writeLMDB ::
  forall m a.
  (MonadIO m, MonadCatch m, MonadThrow m) =>
  WriteOptions m a ->
  Database ReadWrite ->
  Transaction ReadWrite ReadWrite ->
  Fold m (ByteString, ByteString) a
writeLMDB :: forall (m :: * -> *) a.
(MonadIO m, MonadCatch m, MonadThrow m) =>
WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
writeLMDB =
  UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m, MonadThrow m) =>
UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
writeLMDB' (Bool -> UseUnsafeFFI
UseUnsafeFFI Bool
False)

-- | Similar to 'writeLMDB', except that it has an extra 'UseUnsafeFFI' parameter.
--
-- /Internal/.
{-# INLINE writeLMDB' #-}
writeLMDB' ::
  forall m a.
  (MonadIO m, MonadCatch m, MonadThrow m) =>
  UseUnsafeFFI ->
  WriteOptions m a ->
  Database ReadWrite ->
  Transaction ReadWrite ReadWrite ->
  Fold m (ByteString, ByteString) a
writeLMDB' :: forall (m :: * -> *) a.
(MonadIO m, MonadCatch m, MonadThrow m) =>
UseUnsafeFFI
-> WriteOptions m a
-> Database ReadWrite
-> Transaction ReadWrite ReadWrite
-> Fold m (ByteString, ByteString) a
writeLMDB'
  (UseUnsafeFFI Bool
us)
  WriteOptions m a
wopts
  (Database env :: Environment ReadWrite
env@(Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) MDB_dbi_t
dbi)
  txn :: Transaction ReadWrite ReadWrite
txn@(Transaction Environment ReadWrite
_ Ptr MDB_txn
ptxn) =
    -- Notes on why writeLMDB relies on the user creating read-write transactions up front, as
    -- opposed to writeLMDB itself maintaining the write transactions internally (as was the case in
    -- versions <=0.7.0):
    --   * The old way was not safe because LMDB read-write transactions are (unless MDB_NOLOCK is
    --     used) not allowed to cross OS threads; but upon asynchronous exceptions, the read-write
    --     transaction aborting would happen upon garbage collection (GC), which can occur on a
    --     different OS thread (even if the user ran the original writeLMDB on a bound thread).
    --   * We see no way around this but to wrap every read-write transaction in a bona fide bracket
    --     managed by the user (not a streamly-type bracket, which, again, relies on GC).
    --   * Two things we investigated: (a) Channels allow us to pass all writing to a specific OS
    --     thread, but doing this one-by-one for every mdb_put is way too slow; for channels to
    --     become performant, they need chunking. (b) We can use MDB_NOLOCK to avoid the
    --     same-OS-thread requirement, but this means other processes can no longer safely interact
    --     with the LMDB environment.
    --   * Two benefits of the new way: (a) A stream can be demuxed into writeLMDB folds on the same
    --     environment. (b) The writeLMDB fold works with scans.
    let put_ :: Ptr MDB_txn
-> MDB_dbi_t
-> Ptr CChar
-> CSize
-> Ptr CChar
-> CSize
-> CUInt
-> IO ()
put_ =
          if Bool
us
            then Ptr MDB_txn
-> MDB_dbi_t
-> Ptr CChar
-> CSize
-> Ptr CChar
-> CSize
-> CUInt
-> IO ()
mdb_put_unsafe_
            else Ptr MDB_txn
-> MDB_dbi_t
-> Ptr CChar
-> CSize
-> Ptr CChar
-> CSize
-> CUInt
-> IO ()
mdb_put_

        throwErr :: String -> m a
throwErr = String -> String -> m a
forall (m :: * -> *) a. String -> String -> m a
throwError String
"writeLMDB"

        {-# INLINE validate #-}
        validate :: m ()
validate = do
          let (TMVarS NumReaders
_, WriteLock
_, WriteThread MVar ThreadId
writeThread, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> MVar ThreadId -> (String -> IO ()) -> IO ()
detectUserErrors Bool
False MVar ThreadId
writeThread String -> IO ()
forall {m :: * -> *} {a}. String -> m a
throwErr

        {-# INLINE putCatchKeyExists #-}
        putCatchKeyExists ::
          ByteString ->
          ByteString ->
          s -> -- State of the Accum fold (for the failures).
          CUInt ->
          (() -> m (F.Step s d)) ->
          m (F.Step s d)
        putCatchKeyExists :: forall s d.
ByteString
-> ByteString -> s -> CUInt -> (() -> m (Step s d)) -> m (Step s d)
putCatchKeyExists ByteString
k ByteString
v s
s CUInt
op =
          (LMDB_Error -> Maybe ())
-> m (Step s d) -> (() -> m (Step s d)) -> m (Step s d)
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
            ( \case
                LMDB_Error {e_code :: LMDB_Error -> Either Int MDB_ErrCode
e_code = Right MDB_ErrCode
MDB_KEYEXIST} -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
                LMDB_Error
_ -> Maybe ()
forall a. Maybe a
Nothing
            )
            ( do
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) ->
                    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
v ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
vp, Int
vl) ->
                      Ptr MDB_txn
-> MDB_dbi_t
-> Ptr CChar
-> CSize
-> Ptr CChar
-> CSize
-> CUInt
-> IO ()
put_ Ptr MDB_txn
ptxn MDB_dbi_t
dbi Ptr CChar
kp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
vp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
vl) CUInt
op
                Step s d -> m (Step s d)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step s d -> m (Step s d)) -> Step s d -> m (Step s d)
forall a b. (a -> b) -> a -> b
$ s -> Step s d
forall s b. s -> Step s b
F.Partial s
s
            )

        {-# INLINE commonFold #-}
        commonFold :: Fold m (ByteString, ByteString) a
-> CUInt -> Fold m (ByteString, ByteString) a
commonFold (F.Fold s -> (ByteString, ByteString) -> m (Step s a)
fstep m (Step s a)
finit s -> m a
fextr s -> m a
ffinal) CUInt
op =
          forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold @m
            (\s
s (ByteString
k, ByteString
v) -> ByteString
-> ByteString -> s -> CUInt -> (() -> m (Step s a)) -> m (Step s a)
forall s d.
ByteString
-> ByteString -> s -> CUInt -> (() -> m (Step s d)) -> m (Step s d)
putCatchKeyExists ByteString
k ByteString
v s
s CUInt
op (\() -> s -> (ByteString, ByteString) -> m (Step s a)
fstep s
s (ByteString
k, ByteString
v)))
            (m ()
validate m () -> m (Step s a) -> m (Step s a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Step s a)
finit)
            s -> m a
fextr
            s -> m a
ffinal
     in case WriteOptions m a -> OverwriteOptions m a
forall (m :: * -> *) a. WriteOptions m a -> OverwriteOptions m a
writeOverwriteOptions WriteOptions m a
wopts of
          OverwriteOptions m a
OverwriteAllow ->
            forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m b) -> m b -> Fold m a b
F.foldlM' @m @()
              ( \() (ByteString
k, ByteString
v) -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) -> ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
v ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
vp, Int
vl) ->
                    Ptr MDB_txn
-> MDB_dbi_t
-> Ptr CChar
-> CSize
-> Ptr CChar
-> CSize
-> CUInt
-> IO ()
put_ Ptr MDB_txn
ptxn MDB_dbi_t
dbi Ptr CChar
kp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
vp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
vl) CUInt
0
              )
              m ()
validate
          OverwriteDisallow (Left Fold m (ByteString, ByteString) a
f) ->
            Fold m (ByteString, ByteString) a
-> CUInt -> Fold m (ByteString, ByteString) a
commonFold Fold m (ByteString, ByteString) a
f CUInt
mdb_nooverwrite
          OverwriteDisallow (Right (F.Fold s -> (ByteString, ByteString, ByteString) -> m (Step s a)
fstep m (Step s a)
finit s -> m a
fextr s -> m a
ffinal)) ->
            forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b
F.Fold @m
              ( \s
s (ByteString
k, ByteString
v) ->
                  ByteString
-> ByteString -> s -> CUInt -> (() -> m (Step s a)) -> m (Step s a)
forall s d.
ByteString
-> ByteString -> s -> CUInt -> (() -> m (Step s d)) -> m (Step s d)
putCatchKeyExists ByteString
k ByteString
v s
s CUInt
mdb_nooverwrite ((() -> m (Step s a)) -> m (Step s a))
-> (() -> m (Step s a)) -> m (Step s a)
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
                    Maybe ByteString
mVold <- IO (Maybe ByteString) -> m (Maybe ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Database ReadWrite
-> MaybeTxn ReadWrite (Transaction ReadWrite ReadWrite)
-> ByteString
-> IO (Maybe ByteString)
forall emode tmode.
(Mode emode, Mode tmode, SubMode emode tmode) =>
Database emode
-> MaybeTxn tmode (Transaction tmode emode)
-> ByteString
-> IO (Maybe ByteString)
getLMDB (Environment ReadWrite -> MDB_dbi_t -> Database ReadWrite
forall {k} (emode :: k).
Environment emode -> MDB_dbi_t -> Database emode
Database Environment ReadWrite
env MDB_dbi_t
dbi) (Transaction ReadWrite ReadWrite
-> MaybeTxn ReadWrite (Transaction ReadWrite ReadWrite)
forall a tmode. a -> MaybeTxn tmode a
JustTxn Transaction ReadWrite ReadWrite
txn) ByteString
k
                    ByteString
vold <- case Maybe ByteString
mVold of
                      Maybe ByteString
Nothing -> String -> m ByteString
forall {m :: * -> *} {a}. String -> m a
throwErr String
"getLMDB; old value not found; this should never happen"
                      Just ByteString
vold -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
vold
                    s -> (ByteString, ByteString, ByteString) -> m (Step s a)
fstep s
s (ByteString
k, ByteString
v, ByteString
vold)
              )
              (m ()
validate m () -> m (Step s a) -> m (Step s a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Step s a)
finit)
              s -> m a
fextr
              s -> m a
ffinal
          OverwriteAppend Fold m (ByteString, ByteString) a
f ->
            Fold m (ByteString, ByteString) a
-> CUInt -> Fold m (ByteString, ByteString) a
commonFold Fold m (ByteString, ByteString) a
f CUInt
mdb_append

-- | Waits for active read-only transactions on the given environment to finish. Note: This triggers
-- garbage collection.
waitReaders :: (Mode emode) => Environment emode -> IO ()
waitReaders :: forall emode. Mode emode => Environment emode -> IO ()
waitReaders (Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) = do
  let (TMVarS NumReaders
numReadersT, WriteLock
_, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  IO ()
performGC -- Complete active readers as soon as possible.
  NumReaders
numReaders <-
    STM NumReaders -> IO NumReaders
forall a. STM a -> IO a
atomically (STM NumReaders -> IO NumReaders)
-> STM NumReaders -> IO NumReaders
forall a b. (a -> b) -> a -> b
$ do
      NumReaders
numReaders <- TMVarS NumReaders -> STM NumReaders
forall a. TMVarS a -> STM a
takeTMVarS TMVarS NumReaders
numReadersT
      Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ NumReaders
numReaders NumReaders -> NumReaders -> Bool
forall a. Ord a => a -> a -> Bool
<= NumReaders
0 -- Sanity check: use <=0 to catch unexpected negative readers.
      NumReaders -> STM NumReaders
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return NumReaders
numReaders
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NumReaders
numReaders NumReaders -> NumReaders -> Bool
forall a. Eq a => a -> a -> Bool
/= NumReaders
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
forall (m :: * -> *) a. String -> String -> m a
throwError String
"waitReaders" String
"zero numReaders expected"

-- | Clears, i.e., removes all key-value pairs from, the given database.
--
-- /Warning/: Under the hood, this function spawns a bound thread and creates a potentially
-- long-lived read-write transaction; see [Transactions](#g:transactions).
clearDatabase :: Database ReadWrite -> IO ()
clearDatabase :: Database ReadWrite -> IO ()
clearDatabase (Database (Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars) MDB_dbi_t
dbi) = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  let (TMVarS NumReaders
_, WriteLock MVar ()
lock, WriteThread
_, CloseDbLock
_) = (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
mvars
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock () -- Interruptible when waiting for other read-write transactions.
  let disclaimWriteOwnership :: IO ()
disclaimWriteOwnership = MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock

  IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally
    ( IO () -> IO ()
forall a. IO a -> IO a
runInBoundThread (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Ptr MDB_txn
ptxn <- Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
0
        IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
          -- Unmask a potentially long-running operation.
          ( IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Ptr MDB_txn -> MDB_dbi_t -> IO ()
mdb_clear Ptr MDB_txn
ptxn MDB_dbi_t
dbi
              Ptr MDB_txn -> IO ()
mdb_txn_commit Ptr MDB_txn
ptxn
          )
          (Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn) -- TODO: Could abort be long-running?
    )
    IO ()
disclaimWriteOwnership

-- | Deletes the given key from the given database using the given transaction.
{-# INLINE deleteLMDB #-}
deleteLMDB ::
  DeleteOptions ->
  Database emode ->
  Transaction ReadWrite emode ->
  ByteString ->
  IO ()
deleteLMDB :: forall {k} (emode :: k).
DeleteOptions
-> Database emode
-> Transaction ReadWrite emode
-> ByteString
-> IO ()
deleteLMDB DeleteOptions
dopts (Database (Environment Ptr MDB_env
_ (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
_) MDB_dbi_t
dbi) (Transaction Environment emode
_ Ptr MDB_txn
ptxn) ByteString
k =
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
k ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
kp, Int
kl) ->
    MDB_val -> (Ptr MDB_val -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (CSize -> Ptr CChar -> MDB_val
MDB_val (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kl) Ptr CChar
kp) ((Ptr MDB_val -> IO ()) -> IO ())
-> (Ptr MDB_val -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr MDB_val
pk ->
      Ptr MDB_txn -> MDB_dbi_t -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
c_mdb_del Ptr MDB_txn
ptxn MDB_dbi_t
dbi Ptr MDB_val
pk Ptr MDB_val
forall a. Ptr a
nullPtr IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
rc ->
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
mdb_notfound Bool -> Bool -> Bool
&& Bool -> Bool
not DeleteOptions
dopts.deleteAssumeExists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> CInt -> IO ()
forall noReturn. String -> CInt -> IO noReturn
throwLMDBErrNum String
"mdb_del" CInt
rc

newtype DeleteOptions = DeleteOptions
  { -- | Assume that the key being deleted already exists in the database and throw if it doesn’t.
    DeleteOptions -> Bool
deleteAssumeExists :: Bool
  }
  deriving (Int -> DeleteOptions -> String -> String
[DeleteOptions] -> String -> String
DeleteOptions -> String
(Int -> DeleteOptions -> String -> String)
-> (DeleteOptions -> String)
-> ([DeleteOptions] -> String -> String)
-> Show DeleteOptions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DeleteOptions -> String -> String
showsPrec :: Int -> DeleteOptions -> String -> String
$cshow :: DeleteOptions -> String
show :: DeleteOptions -> String
$cshowList :: [DeleteOptions] -> String -> String
showList :: [DeleteOptions] -> String -> String
Show)

-- | By default, we do /not/ assume the key being deleted already exists in the database.
defaultDeleteOptions :: DeleteOptions
defaultDeleteOptions :: DeleteOptions
defaultDeleteOptions =
  DeleteOptions {deleteAssumeExists :: Bool
deleteAssumeExists = Bool
False}

-- | A convenience constant for obtaining 1 KiB.
kibibyte :: (Num a) => a
kibibyte :: forall a. Num a => a
kibibyte = a
1_024

-- | A convenience constant for obtaining 1 MiB.
mebibyte :: (Num a) => a
mebibyte :: forall a. Num a => a
mebibyte = a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024

-- | A convenience constant for obtaining 1 GiB.
gibibyte :: (Num a) => a
gibibyte :: forall a. Num a => a
gibibyte = a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024

-- | A convenience constant for obtaining 1 TiB.
tebibyte :: (Num a) => a
tebibyte :: forall a. Num a => a
tebibyte = a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1_024

-- | A type class for 'ReadOnly' and 'ReadWrite' environments and transactions.
class Mode a where
  isReadOnlyMode :: a -> Bool

data ReadWrite

data ReadOnly

instance Mode ReadWrite where isReadOnlyMode :: ReadWrite -> Bool
isReadOnlyMode ReadWrite
_ = Bool
False

instance Mode ReadOnly where isReadOnlyMode :: ReadOnly -> Bool
isReadOnlyMode ReadOnly
_ = Bool
True

-- | Enforces at the type level that @ReadWrite@ environments support both @ReadWrite@ and
-- @ReadOnly@ transactions, but @ReadOnly@ environments support only @ReadOnly@ transactions.
type SubMode :: k -> k -> Constraint
type family SubMode emode tmode where
  SubMode ReadWrite _ = ()
  SubMode ReadOnly ReadOnly = ()
  SubMode ReadOnly ReadWrite =
    TypeError ('Text "ReadOnly environments only support ReadOnly transactions")

data Environment emode
  = Environment
      !(Ptr MDB_env)
      !(TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)

newtype TMVarS a = TMVarS (TMVar a)

{-# INLINE newTMVarSIO #-}
newTMVarSIO :: a -> IO (TMVarS a)
newTMVarSIO :: forall a. a -> IO (TMVarS a)
newTMVarSIO a
a =
  TMVar a -> TMVarS a
forall a. TMVar a -> TMVarS a
TMVarS (TMVar a -> TMVarS a) -> IO (TMVar a) -> IO (TMVarS a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (TMVar a)
forall a. a -> IO (TMVar a)
newTMVarIO a
a

{-# INLINE takeTMVarS #-}
takeTMVarS :: TMVarS a -> STM a
takeTMVarS :: forall a. TMVarS a -> STM a
takeTMVarS (TMVarS TMVar a
tmVar) =
  TMVar a -> STM a
forall a. TMVar a -> STM a
takeTMVar TMVar a
tmVar

-- Same as putTMVar except it makes sure the value is evaluated to WHNF. (For now we only use this
-- to prevent NumReaders thunks, for which WHNF is enough.)
{-# INLINE putTMVarS #-}
putTMVarS :: TMVarS a -> a -> STM ()
putTMVarS :: forall a. TMVarS a -> a -> STM ()
putTMVarS (TMVarS TMVar a
tmVar) a
a =
  TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tmVar (a -> STM ()) -> a -> STM ()
forall a b. (a -> b) -> a -> b
$! a
a

-- The number of current readers. This needs to be kept track of due to MDB_NOLOCK; see comments in
-- writeLMDB.
newtype NumReaders = NumReaders Int deriving (NumReaders -> NumReaders -> Bool
(NumReaders -> NumReaders -> Bool)
-> (NumReaders -> NumReaders -> Bool) -> Eq NumReaders
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumReaders -> NumReaders -> Bool
== :: NumReaders -> NumReaders -> Bool
$c/= :: NumReaders -> NumReaders -> Bool
/= :: NumReaders -> NumReaders -> Bool
Eq, Integer -> NumReaders
NumReaders -> NumReaders
NumReaders -> NumReaders -> NumReaders
(NumReaders -> NumReaders -> NumReaders)
-> (NumReaders -> NumReaders -> NumReaders)
-> (NumReaders -> NumReaders -> NumReaders)
-> (NumReaders -> NumReaders)
-> (NumReaders -> NumReaders)
-> (NumReaders -> NumReaders)
-> (Integer -> NumReaders)
-> Num NumReaders
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: NumReaders -> NumReaders -> NumReaders
+ :: NumReaders -> NumReaders -> NumReaders
$c- :: NumReaders -> NumReaders -> NumReaders
- :: NumReaders -> NumReaders -> NumReaders
$c* :: NumReaders -> NumReaders -> NumReaders
* :: NumReaders -> NumReaders -> NumReaders
$cnegate :: NumReaders -> NumReaders
negate :: NumReaders -> NumReaders
$cabs :: NumReaders -> NumReaders
abs :: NumReaders -> NumReaders
$csignum :: NumReaders -> NumReaders
signum :: NumReaders -> NumReaders
$cfromInteger :: Integer -> NumReaders
fromInteger :: Integer -> NumReaders
Num, Eq NumReaders
Eq NumReaders =>
(NumReaders -> NumReaders -> Ordering)
-> (NumReaders -> NumReaders -> Bool)
-> (NumReaders -> NumReaders -> Bool)
-> (NumReaders -> NumReaders -> Bool)
-> (NumReaders -> NumReaders -> Bool)
-> (NumReaders -> NumReaders -> NumReaders)
-> (NumReaders -> NumReaders -> NumReaders)
-> Ord NumReaders
NumReaders -> NumReaders -> Bool
NumReaders -> NumReaders -> Ordering
NumReaders -> NumReaders -> NumReaders
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NumReaders -> NumReaders -> Ordering
compare :: NumReaders -> NumReaders -> Ordering
$c< :: NumReaders -> NumReaders -> Bool
< :: NumReaders -> NumReaders -> Bool
$c<= :: NumReaders -> NumReaders -> Bool
<= :: NumReaders -> NumReaders -> Bool
$c> :: NumReaders -> NumReaders -> Bool
> :: NumReaders -> NumReaders -> Bool
$c>= :: NumReaders -> NumReaders -> Bool
>= :: NumReaders -> NumReaders -> Bool
$cmax :: NumReaders -> NumReaders -> NumReaders
max :: NumReaders -> NumReaders -> NumReaders
$cmin :: NumReaders -> NumReaders -> NumReaders
min :: NumReaders -> NumReaders -> NumReaders
Ord)

-- An increasing counter for various write-related functions using the same environment.
newtype WriteCounter = WriterCounter Int deriving (WriteCounter
WriteCounter -> WriteCounter -> Bounded WriteCounter
forall a. a -> a -> Bounded a
$cminBound :: WriteCounter
minBound :: WriteCounter
$cmaxBound :: WriteCounter
maxBound :: WriteCounter
Bounded, WriteCounter -> WriteCounter -> Bool
(WriteCounter -> WriteCounter -> Bool)
-> (WriteCounter -> WriteCounter -> Bool) -> Eq WriteCounter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WriteCounter -> WriteCounter -> Bool
== :: WriteCounter -> WriteCounter -> Bool
$c/= :: WriteCounter -> WriteCounter -> Bool
/= :: WriteCounter -> WriteCounter -> Bool
Eq, Integer -> WriteCounter
WriteCounter -> WriteCounter
WriteCounter -> WriteCounter -> WriteCounter
(WriteCounter -> WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter)
-> (Integer -> WriteCounter)
-> Num WriteCounter
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WriteCounter -> WriteCounter -> WriteCounter
+ :: WriteCounter -> WriteCounter -> WriteCounter
$c- :: WriteCounter -> WriteCounter -> WriteCounter
- :: WriteCounter -> WriteCounter -> WriteCounter
$c* :: WriteCounter -> WriteCounter -> WriteCounter
* :: WriteCounter -> WriteCounter -> WriteCounter
$cnegate :: WriteCounter -> WriteCounter
negate :: WriteCounter -> WriteCounter
$cabs :: WriteCounter -> WriteCounter
abs :: WriteCounter -> WriteCounter
$csignum :: WriteCounter -> WriteCounter
signum :: WriteCounter -> WriteCounter
$cfromInteger :: Integer -> WriteCounter
fromInteger :: Integer -> WriteCounter
Num, Eq WriteCounter
Eq WriteCounter =>
(WriteCounter -> WriteCounter -> Ordering)
-> (WriteCounter -> WriteCounter -> Bool)
-> (WriteCounter -> WriteCounter -> Bool)
-> (WriteCounter -> WriteCounter -> Bool)
-> (WriteCounter -> WriteCounter -> Bool)
-> (WriteCounter -> WriteCounter -> WriteCounter)
-> (WriteCounter -> WriteCounter -> WriteCounter)
-> Ord WriteCounter
WriteCounter -> WriteCounter -> Bool
WriteCounter -> WriteCounter -> Ordering
WriteCounter -> WriteCounter -> WriteCounter
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WriteCounter -> WriteCounter -> Ordering
compare :: WriteCounter -> WriteCounter -> Ordering
$c< :: WriteCounter -> WriteCounter -> Bool
< :: WriteCounter -> WriteCounter -> Bool
$c<= :: WriteCounter -> WriteCounter -> Bool
<= :: WriteCounter -> WriteCounter -> Bool
$c> :: WriteCounter -> WriteCounter -> Bool
> :: WriteCounter -> WriteCounter -> Bool
$c>= :: WriteCounter -> WriteCounter -> Bool
>= :: WriteCounter -> WriteCounter -> Bool
$cmax :: WriteCounter -> WriteCounter -> WriteCounter
max :: WriteCounter -> WriteCounter -> WriteCounter
$cmin :: WriteCounter -> WriteCounter -> WriteCounter
min :: WriteCounter -> WriteCounter -> WriteCounter
Ord)

-- | Keeps track of the 'ThreadId' of the current read-write transaction.
newtype WriteThread = WriteThread (MVar ThreadId)

-- For read-write transaction serialization.
newtype WriteLock = WriteLock (MVar ())

-- For closeDatabase serialization.
newtype CloseDbLock = CloseDbLock (MVar ())

data Database emode = Database !(Environment emode) !MDB_dbi_t

-- | Utility function for getting a named database with a read-only transaction, returning 'Nothing'
-- if it was not found.
--
-- /Internal/.
getNamedDb ::
  forall emode.
  (Mode emode) =>
  Environment emode ->
  String ->
  IO (Maybe MDB_dbi_t)
getNamedDb :: forall emode.
Mode emode =>
Environment emode -> String -> IO (Maybe MDB_dbi_t)
getNamedDb (Environment Ptr MDB_env
penv (TMVarS NumReaders, WriteLock, WriteThread, CloseDbLock)
_) String
name = IO (Maybe MDB_dbi_t) -> IO (Maybe MDB_dbi_t)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Maybe MDB_dbi_t) -> IO (Maybe MDB_dbi_t))
-> IO (Maybe MDB_dbi_t) -> IO (Maybe MDB_dbi_t)
forall a b. (a -> b) -> a -> b
$ do
  -- Use a read-only transaction to try to get the named database.
  Ptr MDB_txn
ptxn <- Ptr MDB_env -> Ptr MDB_txn -> CUInt -> IO (Ptr MDB_txn)
mdb_txn_begin Ptr MDB_env
penv Ptr MDB_txn
forall a. Ptr a
nullPtr CUInt
mdb_rdonly
  IO (Maybe MDB_dbi_t) -> IO () -> IO (Maybe MDB_dbi_t)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
onException
    ( (LMDB_Error -> Maybe ())
-> IO (Maybe MDB_dbi_t)
-> (() -> IO (Maybe MDB_dbi_t))
-> IO (Maybe MDB_dbi_t)
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
        ( \case
            -- Assumption: mdb_txn_commit never returns MDB_NOTFOUND.
            LMDB_Error {Either Int MDB_ErrCode
e_code :: LMDB_Error -> Either Int MDB_ErrCode
e_code :: Either Int MDB_ErrCode
e_code} | Either Int MDB_ErrCode
e_code Either Int MDB_ErrCode -> Either Int MDB_ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
== MDB_ErrCode -> Either Int MDB_ErrCode
forall a b. b -> Either a b
Right MDB_ErrCode
MDB_NOTFOUND -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
            LMDB_Error
_ -> Maybe ()
forall a. Maybe a
Nothing
        )
        (MDB_dbi_t -> Maybe MDB_dbi_t
forall a. a -> Maybe a
Just (MDB_dbi_t -> Maybe MDB_dbi_t)
-> IO MDB_dbi_t -> IO (Maybe MDB_dbi_t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MDB_txn -> Maybe String -> CUInt -> IO MDB_dbi_t
mdb_dbi_open Ptr MDB_txn
ptxn (String -> Maybe String
forall a. a -> Maybe a
Just String
name) CUInt
0 IO (Maybe MDB_dbi_t) -> IO () -> IO (Maybe MDB_dbi_t)
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Ptr MDB_txn -> IO ()
mdb_txn_commit Ptr MDB_txn
ptxn)
        ( \() -> do
            -- The named database was not found.
            Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn
            Maybe MDB_dbi_t -> IO (Maybe MDB_dbi_t)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MDB_dbi_t
forall a. Maybe a
Nothing
        )
    )
    (Ptr MDB_txn -> IO ()
c_mdb_txn_abort Ptr MDB_txn
ptxn)

-- | A utility function for detecting a few user errors.
--
-- /Internal/.
detectUserErrors :: Bool -> MVar ThreadId -> (String -> IO ()) -> IO ()
detectUserErrors :: Bool -> MVar ThreadId -> (String -> IO ()) -> IO ()
detectUserErrors Bool
shouldTake MVar ThreadId
writeThread String -> IO ()
throwErr = do
  let info :: String
info = String
"LMDB transactions might now be in a mangled state"
      inappr :: t -> t
inappr t
ctx = String -> t -> String -> t
forall r. PrintfType r => String -> r
printf String
"inappropriately called (%s); %s" t
ctx String
info
      unexpThread :: String
unexpThread = String
"called on unexpected thread; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
info
      caseShouldTake :: String
caseShouldTake = String
"before aborting/committing read-write transaction"
      caseNotShouldTake :: String
caseNotShouldTake = String
"before starting writeLMDB"
  ThreadId
threadId <- IO ThreadId
myThreadId
  if Bool
shouldTake
    then
      -- Before aborting/committing read-write transactions.
      MVar ThreadId -> IO (Maybe ThreadId)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
writeThread IO (Maybe ThreadId) -> (Maybe ThreadId -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ThreadId
Nothing -> String -> IO ()
throwErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall {t} {t}. (PrintfArg t, PrintfType t) => t -> t
inappr String
caseShouldTake
        Just ThreadId
tid
          | ThreadId
tid ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadId
threadId -> String -> IO ()
throwErr String
unexpThread
          | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
      -- Before starting a writeLMDB.
      MVar ThreadId -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ThreadId
writeThread IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> IO ()
throwErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall {t} {t}. (PrintfArg t, PrintfType t) => t -> t
inappr String
caseNotShouldTake)
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar ThreadId -> (ThreadId -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVarMasked MVar ThreadId
writeThread ((ThreadId -> IO ()) -> IO ()) -> (ThreadId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ThreadId
tid ->
        if ThreadId
tid ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadId
threadId
          then String -> IO ()
throwErr String
unexpThread
          else IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ThreadId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
tid

-- |
-- @liftedBracket2 acquire failure success thing@
--
-- Same as @Control.Exception.Lifted.bracket@ (from @lifted-base@) except it distinguishes between
-- failure and success.
--
-- Notes:
--
-- * When @acquire@, @success@, or @failure@ throw exceptions, any monadic side effects in @m@ will
--   be discarded.
-- * When @thing@ throws an exception, any monadic side effects in @m@ produced by @thing@ will be
--   discarded, but the side effects of @acquire@ and (non-excepting) @failure@ will be retained.
-- * When (following a @thing@ success) @success@ throws an exception, any monadic side effects in
--   @m@ produced by @success@ will be discarded, but the side effects of @acquire@, @thing@, and
--   (non-excepting) @failure@ will be retained.
--
-- /Internal/.
{-# INLINE liftedBracket2 #-}
liftedBracket2 ::
  (MonadBaseControl IO m) =>
  m a ->
  (a -> m b) ->
  (a -> m b) ->
  (a -> m c) ->
  m c
liftedBracket2 :: forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m b) -> (a -> m c) -> m c
liftedBracket2 m a
acquire a -> m b
failure a -> m b
success a -> m c
thing = (RunInBase m IO -> IO (StM m c)) -> m c
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m c)) -> m c)
-> (RunInBase m IO -> IO (StM m c)) -> m c
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
  IO (StM m a)
-> (StM m a -> IO (StM m b))
-> (StM m a -> IO (StM m b))
-> (StM m a -> IO (StM m c))
-> IO (StM m c)
forall a b c.
IO a -> (a -> IO b) -> (a -> IO b) -> (a -> IO c) -> IO c
bracket2
    (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
acquire)
    (\StM m a
st -> m b -> IO (StM m b)
RunInBase m IO
runInIO (m b -> IO (StM m b)) -> m b -> IO (StM m b)
forall a b. (a -> b) -> a -> b
$ StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m a
st m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
failure)
    (\StM m a
st -> m b -> IO (StM m b)
RunInBase m IO
runInIO (m b -> IO (StM m b)) -> m b -> IO (StM m b)
forall a b. (a -> b) -> a -> b
$ StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m a
st m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
success)
    (\StM m a
st -> m c -> IO (StM m c)
RunInBase m IO
runInIO (m c -> IO (StM m c)) -> m c -> IO (StM m c)
forall a b. (a -> b) -> a -> b
$ StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m a
st m a -> (a -> m c) -> m c
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m c
thing)

-- | Same as @Control.Exception.bracket@ except it distinguishes between failure and success. (If
-- the success action throws an exception, the failure action gets called.)
--
-- /Internal/.
{-# INLINE bracket2 #-}
bracket2 ::
  IO a ->
  (a -> IO b) ->
  (a -> IO b) ->
  (a -> IO c) ->
  IO c
bracket2 :: forall a b c.
IO a -> (a -> IO b) -> (a -> IO b) -> (a -> IO c) -> IO c
bracket2 IO a
acquire a -> IO b
failure a -> IO b
success a -> IO c
thing = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  a
a <- IO a
acquire
  c
r <- IO c -> IO c
forall a. IO a -> IO a
restore (a -> IO c
thing a
a) IO c -> IO b -> IO c
forall a b. IO a -> IO b -> IO a
`E.onException` a -> IO b
failure a
a
  b
_ <- a -> IO b
success a
a IO b -> IO b -> IO b
forall a b. IO a -> IO b -> IO a
`E.onException` a -> IO b
failure a
a
  c -> IO c
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return c
r