module Database.LMDB.Simple.DBRef
( DBRef
, newDBRef
, readDBRef
, writeDBRef
, modifyDBRef_
, modifyDBRef
) where
import Control.Monad
( (>=>)
, void
)
import Control.Monad.IO.Class
( MonadIO (liftIO)
)
import Data.Binary
( Binary
, encode
)
import Data.ByteString
( ByteString
)
import Data.ByteString.Lazy
( toStrict
)
import Data.ByteString.Unsafe
( unsafeUseAsCStringLen
)
import Database.LMDB.Raw
( MDB_dbi'
, MDB_val (..)
, mdb_get'
, mdb_put'
, mdb_del'
)
import Database.LMDB.Simple
( transaction
)
import Database.LMDB.Simple.Internal
( Environment (..)
, Transaction (..)
, Database (..)
, ReadWrite
, ReadOnly
, marshalIn
, marshalOut
, defaultWriteFlags
)
import Foreign
( castPtr
)
data DBRef mode a = Ref (Environment mode) MDB_dbi' ByteString
newDBRef :: Binary k
=> Environment mode -> Database k a -> k -> IO (DBRef mode a)
newDBRef env (Db _ dbi) = return . Ref env dbi . toStrict . encode
withVal :: ByteString -> (MDB_val -> IO a) -> IO a
withVal bs f = unsafeUseAsCStringLen bs $ \(ptr, len) ->
f $ MDB_val (fromIntegral len) (castPtr ptr)
readDBRef :: Binary a => DBRef mode a -> IO (Maybe a)
readDBRef ref@(Ref env dbi key) = transaction env (tx ref)
where tx :: Binary a => DBRef mode a -> Transaction ReadOnly (Maybe a)
tx _ = Txn $ \txn -> withVal key $ mdb_get' txn dbi >=>
maybe (return Nothing) (liftIO . fmap Just . marshalIn)
writeDBRef :: Binary a => DBRef ReadWrite a -> Maybe a -> IO ()
writeDBRef (Ref env dbi key) = transaction env . maybe delKey putKey
where delKey :: Transaction ReadWrite ()
delKey = Txn $ \txn -> withVal key $ \kval ->
void $ mdb_del' txn dbi kval Nothing
putKey :: Binary a => a -> Transaction ReadWrite ()
putKey value = Txn $ \txn -> withVal key $ \kval ->
marshalOut value $ \vval ->
void $ mdb_put' defaultWriteFlags txn dbi kval vval
modifyDBRef_ :: Binary a => DBRef ReadWrite a -> (Maybe a -> Maybe a) -> IO ()
modifyDBRef_ ref f = modifyDBRef ref $ \x -> (f x, ())
modifyDBRef :: Binary a => DBRef ReadWrite a -> (Maybe a -> (Maybe a, b)) -> IO b
modifyDBRef (Ref env dbi key) = transaction env . tx
where tx :: Binary a => (Maybe a -> (Maybe a, b)) -> Transaction ReadWrite b
tx f = Txn $ \txn -> withVal key $ \kval -> mdb_get' txn dbi kval >>=
maybe (return Nothing) (fmap Just . marshalIn) >>= \x ->
let (x', r) = f x in maybe (mdb_del' txn dbi kval Nothing)
(flip marshalOut $ mdb_put' defaultWriteFlags txn dbi kval) x' >>
return r