{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-| Alternatives to LMDB operations that do not rely on @'Serialise'@ instances

  We cannot (easily and without runtime overhead) satisfy the @'Serialise'@
  constraints that the @lmdb-simple@ operations require. We have access to the
  codification and decodification functions provided in @'CodecMK'@, thus, we
  redefine parts of the internal @LMDB.Simple@ operations here. The
  redefinitions are largely analogous to their counterparts, though they thread
  through explicit CBOR encoders and decoders.
-}
module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge (
    -- * Cursor
    fromCodecMK
  , runCursorAsTransaction'
    -- * Internal: get and put
  , delete
  , deleteBS
  , get
  , getBS
  , getBS'
  , indexedGet
  , indexedPut
  , put
  , putBS
  ) where

import           Control.Exception (assert)
import           Control.Monad ((>=>))
import qualified Control.Monad as Monad
import           Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.ByteString as BS
import           Data.MemPack
import           Data.MemPack.Buffer
import           Database.LMDB.Raw (MDB_val (..), mdb_reserve')
import           Database.LMDB.Simple (Database, Mode (ReadWrite), Transaction)
import           Database.LMDB.Simple.Cursor (CursorM)
import qualified Database.LMDB.Simple.Cursor as Cursor
import qualified Database.LMDB.Simple.Internal as Internal
import           Foreign (Storable (peek, poke), castPtr)
import           GHC.Ptr (Ptr (..))
import           Ouroboros.Consensus.Util.IndexedMemPack

instance Buffer MDB_val where
  bufferByteCount :: MDB_val -> Int
bufferByteCount = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> (MDB_val -> CSize) -> MDB_val -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDB_val -> CSize
mv_size
  {-# INLINE bufferByteCount #-}

  buffer :: forall a. MDB_val -> (ByteArray# -> a) -> (Addr# -> a) -> a
buffer (MDB_val CSize
_ (Ptr Addr#
addr#)) ByteArray# -> a
_ Addr# -> a
f = Addr# -> a
f Addr#
addr#
  {-# INLINE buffer #-}

{-------------------------------------------------------------------------------
  Internal: peek and poke
-------------------------------------------------------------------------------}

peekMDBValMemPack :: MemPack a => Ptr MDB_val -> IO a
peekMDBValMemPack :: forall a. MemPack a => Ptr MDB_val -> IO a
peekMDBValMemPack = Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek (Ptr MDB_val -> IO MDB_val)
-> (MDB_val -> IO a) -> Ptr MDB_val -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (MDB_val -> a) -> MDB_val -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDB_val -> a
forall a b. (MemPack a, Buffer b, HasCallStack) => b -> a
unpackError

pokeMDBValMemPack :: MemPack a => Ptr MDB_val -> a -> IO ()
pokeMDBValMemPack :: forall a. MemPack a => Ptr MDB_val -> a -> IO ()
pokeMDBValMemPack Ptr MDB_val
ptr a
x = ByteString -> (MDB_val -> IO ()) -> IO ()
forall a. ByteString -> (MDB_val -> IO a) -> IO a
Internal.marshalOutBS (a -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString a
x) (Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
ptr)

indexedPeekMDBValMemPack :: IndexedMemPack idx a => idx -> Ptr MDB_val -> IO a
indexedPeekMDBValMemPack :: forall idx a. IndexedMemPack idx a => idx -> Ptr MDB_val -> IO a
indexedPeekMDBValMemPack idx
idx = Ptr MDB_val -> IO MDB_val
forall a. Storable a => Ptr a -> IO a
peek (Ptr MDB_val -> IO MDB_val)
-> (MDB_val -> IO a) -> Ptr MDB_val -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (MDB_val -> a) -> MDB_val -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. idx -> MDB_val -> a
forall idx a b.
(Buffer b, IndexedMemPack idx a, HasCallStack) =>
idx -> b -> a
indexedUnpackError idx
idx

indexedPokeMDBValMemPack :: IndexedMemPack idx a => idx -> Ptr MDB_val -> a -> IO ()
indexedPokeMDBValMemPack :: forall idx a.
IndexedMemPack idx a =>
idx -> Ptr MDB_val -> a -> IO ()
indexedPokeMDBValMemPack idx
idx Ptr MDB_val
ptr a
x = ByteString -> (MDB_val -> IO ()) -> IO ()
forall a. ByteString -> (MDB_val -> IO a) -> IO a
Internal.marshalOutBS (idx -> a -> ByteString
forall a idx.
(IndexedMemPack idx a, HasCallStack) =>
idx -> a -> ByteString
indexedPackByteString idx
idx a
x) (Ptr MDB_val -> MDB_val -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr MDB_val
ptr)

{-------------------------------------------------------------------------------
  Cursor
-------------------------------------------------------------------------------}

fromCodecMK :: (IndexedMemPack idx v, MemPack k) => idx -> Cursor.PeekPoke k v
fromCodecMK :: forall idx v k.
(IndexedMemPack idx v, MemPack k) =>
idx -> PeekPoke k v
fromCodecMK idx
idx = Cursor.PeekPoke {
    kPeek :: Ptr MDB_val -> IO k
Cursor.kPeek = Ptr MDB_val -> IO k
forall a. MemPack a => Ptr MDB_val -> IO a
peekMDBValMemPack
  , vPeek :: Ptr MDB_val -> IO v
Cursor.vPeek = idx -> Ptr MDB_val -> IO v
forall idx a. IndexedMemPack idx a => idx -> Ptr MDB_val -> IO a
indexedPeekMDBValMemPack idx
idx
  , kPoke :: Ptr MDB_val -> k -> IO ()
Cursor.kPoke = Ptr MDB_val -> k -> IO ()
forall a. MemPack a => Ptr MDB_val -> a -> IO ()
pokeMDBValMemPack
  , vPoke :: Ptr MDB_val -> v -> IO ()
Cursor.vPoke = idx -> Ptr MDB_val -> v -> IO ()
forall idx a.
IndexedMemPack idx a =>
idx -> Ptr MDB_val -> a -> IO ()
indexedPokeMDBValMemPack idx
idx
  }

-- | Wrapper around @'Cursor.runCursorAsTransaction''@ that requires a
-- @'CodecMK'@ instead of a @'PeekPoke'@.
runCursorAsTransaction' ::
     (MemPack k, IndexedMemPack idx v)
  => idx
  -> CursorM k v mode a
  -> Database k v
  -> Transaction mode a
runCursorAsTransaction' :: forall k idx v (mode :: Mode) a.
(MemPack k, IndexedMemPack idx v) =>
idx -> CursorM k v mode a -> Database k v -> Transaction mode a
runCursorAsTransaction' idx
idx CursorM k v mode a
cm Database k v
db =
  CursorM k v mode a
-> Database k v -> PeekPoke k v -> Transaction mode a
forall k v (mode :: Mode) a.
CursorM k v mode a
-> Database k v -> PeekPoke k v -> Transaction mode a
Cursor.runCursorAsTransaction' CursorM k v mode a
cm Database k v
db (idx -> PeekPoke k v
forall idx v k.
(IndexedMemPack idx v, MemPack k) =>
idx -> PeekPoke k v
fromCodecMK idx
idx)

{-------------------------------------------------------------------------------
  Internal: get, put and delete
-------------------------------------------------------------------------------}

get ::
     (MemPack k, MemPack v)
  => Database k v
  -> k
  -> Transaction mode (Maybe v)
get :: forall k v (mode :: Mode).
(MemPack k, MemPack v) =>
Database k v -> k -> Transaction mode (Maybe v)
get Database k v
db = Database k v -> ByteString -> Transaction mode (Maybe v)
forall v k (mode :: Mode).
MemPack v =>
Database k v -> ByteString -> Transaction mode (Maybe v)
getBS Database k v
db (ByteString -> Transaction mode (Maybe v))
-> (k -> ByteString) -> k -> Transaction mode (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString

getBS ::
     MemPack v
  => Database k v
  -> BS.ByteString
  -> Transaction mode (Maybe v)
getBS :: forall v k (mode :: Mode).
MemPack v =>
Database k v -> ByteString -> Transaction mode (Maybe v)
getBS Database k v
db ByteString
k = Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
forall k v (mode :: Mode).
Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
getBS' Database k v
db ByteString
k Transaction mode (Maybe MDB_val)
-> (Maybe MDB_val -> Transaction mode (Maybe v))
-> Transaction mode (Maybe v)
forall a b.
Transaction mode a
-> (a -> Transaction mode b) -> Transaction mode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Transaction mode (Maybe v)
-> (MDB_val -> Transaction mode (Maybe v))
-> Maybe MDB_val
-> Transaction mode (Maybe v)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe v -> Transaction mode (Maybe v)
forall a. a -> Transaction mode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing) (IO (Maybe v) -> Transaction mode (Maybe v)
forall a. IO a -> Transaction mode a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> Transaction mode (Maybe v))
-> (MDB_val -> IO (Maybe v))
-> MDB_val
-> Transaction mode (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Maybe v) -> IO v -> IO (Maybe v)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Maybe v
forall a. a -> Maybe a
Just (IO v -> IO (Maybe v))
-> (MDB_val -> IO v) -> MDB_val -> IO (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> IO v
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> IO v) -> (MDB_val -> v) -> MDB_val -> IO v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDB_val -> v
forall a b. (MemPack a, Buffer b, HasCallStack) => b -> a
unpackError)

indexedGet ::
     (IndexedMemPack idx v, MemPack k)
  => idx
  -> Database k v
  -> k
  -> Transaction mode (Maybe v)
indexedGet :: forall idx v k (mode :: Mode).
(IndexedMemPack idx v, MemPack k) =>
idx -> Database k v -> k -> Transaction mode (Maybe v)
indexedGet idx
idx Database k v
db = idx -> Database k v -> ByteString -> Transaction mode (Maybe v)
forall idx v k (mode :: Mode).
IndexedMemPack idx v =>
idx -> Database k v -> ByteString -> Transaction mode (Maybe v)
indexedGetBS idx
idx Database k v
db (ByteString -> Transaction mode (Maybe v))
-> (k -> ByteString) -> k -> Transaction mode (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString

indexedGetBS ::
     IndexedMemPack idx v
  => idx
  -> Database k v
  -> BS.ByteString
  -> Transaction mode (Maybe v)
indexedGetBS :: forall idx v k (mode :: Mode).
IndexedMemPack idx v =>
idx -> Database k v -> ByteString -> Transaction mode (Maybe v)
indexedGetBS idx
idx Database k v
db ByteString
k = Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
forall k v (mode :: Mode).
Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
getBS' Database k v
db ByteString
k Transaction mode (Maybe MDB_val)
-> (Maybe MDB_val -> Transaction mode (Maybe v))
-> Transaction mode (Maybe v)
forall a b.
Transaction mode a
-> (a -> Transaction mode b) -> Transaction mode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Transaction mode (Maybe v)
-> (MDB_val -> Transaction mode (Maybe v))
-> Maybe MDB_val
-> Transaction mode (Maybe v)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe v -> Transaction mode (Maybe v)
forall a. a -> Transaction mode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing) (IO (Maybe v) -> Transaction mode (Maybe v)
forall a. IO a -> Transaction mode a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> Transaction mode (Maybe v))
-> (MDB_val -> IO (Maybe v))
-> MDB_val
-> Transaction mode (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Maybe v) -> IO v -> IO (Maybe v)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Maybe v
forall a. a -> Maybe a
Just (IO v -> IO (Maybe v))
-> (MDB_val -> IO v) -> MDB_val -> IO (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> IO v
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> IO v) -> (MDB_val -> v) -> MDB_val -> IO v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. idx -> MDB_val -> v
forall idx a b.
(Buffer b, IndexedMemPack idx a, HasCallStack) =>
idx -> b -> a
indexedUnpackError idx
idx)

getBS' :: Database k v -> BS.ByteString -> Transaction mode (Maybe MDB_val)
getBS' :: forall k v (mode :: Mode).
Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
getBS' = Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
forall k v (mode :: Mode).
Database k v -> ByteString -> Transaction mode (Maybe MDB_val)
Internal.getBS'

put ::
     (MemPack v, MemPack k)
  => Database k v
  -> k
  -> v
  -> Transaction ReadWrite ()
put :: forall v k.
(MemPack v, MemPack k) =>
Database k v -> k -> v -> Transaction 'ReadWrite ()
put Database k v
db = Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
forall v k.
MemPack v =>
Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
putBS Database k v
db (ByteString -> v -> Transaction 'ReadWrite ())
-> (k -> ByteString) -> k -> v -> Transaction 'ReadWrite ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString

putBS ::
     MemPack v
  => Database k v
  -> BS.ByteString
  -> v
  -> Transaction ReadWrite ()
putBS :: forall v k.
MemPack v =>
Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
putBS (Internal.Db MDB_env
_ MDB_dbi'
dbi) ByteString
keyBS v
value = (MDB_txn -> IO ()) -> Transaction 'ReadWrite ()
forall (mode :: Mode) a. (MDB_txn -> IO a) -> Transaction mode a
Internal.Txn ((MDB_txn -> IO ()) -> Transaction 'ReadWrite ())
-> (MDB_txn -> IO ()) -> Transaction 'ReadWrite ()
forall a b. (a -> b) -> a -> b
$ \MDB_txn
txn ->
  ByteString -> (MDB_val -> IO ()) -> IO ()
forall a. ByteString -> (MDB_val -> IO a) -> IO a
Internal.marshalOutBS ByteString
keyBS ((MDB_val -> IO ()) -> IO ()) -> (MDB_val -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MDB_val
kval -> do
    let valueBS :: ByteString
valueBS = v -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString v
value
        sz :: Int
sz = ByteString -> Int
BS.length ByteString
valueBS
    MDB_val len ptr <- MDB_WriteFlags
-> MDB_txn -> MDB_dbi' -> MDB_val -> Int -> IO MDB_val
mdb_reserve' MDB_WriteFlags
Internal.defaultWriteFlags MDB_txn
txn MDB_dbi'
dbi MDB_val
kval Int
sz
    let len' = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len
    Monad.void $ assert (len' == sz) $ Internal.copyBS (castPtr ptr, len') valueBS

indexedPut ::
     (IndexedMemPack idx v, MemPack k)
  => idx
  -> Database k v
  -> k
  -> v
  -> Transaction ReadWrite ()
indexedPut :: forall idx v k.
(IndexedMemPack idx v, MemPack k) =>
idx -> Database k v -> k -> v -> Transaction 'ReadWrite ()
indexedPut idx
idx Database k v
db = idx -> Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
forall idx v k.
IndexedMemPack idx v =>
idx -> Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
indexedPutBS idx
idx Database k v
db (ByteString -> v -> Transaction 'ReadWrite ())
-> (k -> ByteString) -> k -> v -> Transaction 'ReadWrite ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString

indexedPutBS ::
     IndexedMemPack idx v
  => idx
  -> Database k v
  -> BS.ByteString
  -> v
  -> Transaction ReadWrite ()
indexedPutBS :: forall idx v k.
IndexedMemPack idx v =>
idx -> Database k v -> ByteString -> v -> Transaction 'ReadWrite ()
indexedPutBS idx
idx (Internal.Db MDB_env
_ MDB_dbi'
dbi) ByteString
keyBS v
value = (MDB_txn -> IO ()) -> Transaction 'ReadWrite ()
forall (mode :: Mode) a. (MDB_txn -> IO a) -> Transaction mode a
Internal.Txn ((MDB_txn -> IO ()) -> Transaction 'ReadWrite ())
-> (MDB_txn -> IO ()) -> Transaction 'ReadWrite ()
forall a b. (a -> b) -> a -> b
$ \MDB_txn
txn ->
  ByteString -> (MDB_val -> IO ()) -> IO ()
forall a. ByteString -> (MDB_val -> IO a) -> IO a
Internal.marshalOutBS ByteString
keyBS ((MDB_val -> IO ()) -> IO ()) -> (MDB_val -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MDB_val
kval -> do
    let valueBS :: ByteString
valueBS = idx -> v -> ByteString
forall a idx.
(IndexedMemPack idx a, HasCallStack) =>
idx -> a -> ByteString
indexedPackByteString idx
idx v
value
        sz :: Int
sz = ByteString -> Int
BS.length ByteString
valueBS
    MDB_val len ptr <- MDB_WriteFlags
-> MDB_txn -> MDB_dbi' -> MDB_val -> Int -> IO MDB_val
mdb_reserve' MDB_WriteFlags
Internal.defaultWriteFlags MDB_txn
txn MDB_dbi'
dbi MDB_val
kval Int
sz
    let len' = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len
    Monad.void $ assert (len' == sz) $ Internal.copyBS (castPtr ptr, len') valueBS

delete ::
     MemPack k
  => Database k v
  -> k
  -> Transaction ReadWrite Bool
delete :: forall k v.
MemPack k =>
Database k v -> k -> Transaction 'ReadWrite Bool
delete Database k v
db = Database k v -> ByteString -> Transaction 'ReadWrite Bool
forall k v.
Database k v -> ByteString -> Transaction 'ReadWrite Bool
deleteBS Database k v
db (ByteString -> Transaction 'ReadWrite Bool)
-> (k -> ByteString) -> k -> Transaction 'ReadWrite Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString

deleteBS :: Database k v -> BS.ByteString -> Transaction ReadWrite Bool
deleteBS :: forall k v.
Database k v -> ByteString -> Transaction 'ReadWrite Bool
deleteBS = Database k v -> ByteString -> Transaction 'ReadWrite Bool
forall k v.
Database k v -> ByteString -> Transaction 'ReadWrite Bool
Internal.deleteBS