{-|
Module      : Mdbx.Store
Copyright   : (c) 2021 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Instances and helpers to derive 'MdbxItem' for 'Store' instances.
-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}

module Mdbx.Store (
  MdbxItemStore(..),
  fromMdbxStore,
  withMdbxStore
) where

import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackCStringLen)
import Data.Coerce (coerce)
import Data.Store
import Data.Store.Core
import Data.Word
import Foreign.Ptr

import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as BSH
import qualified Data.ByteString.Internal as BSI
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import Mdbx.Types

{-|
Helper type to derive 'MdbxItem' instances for types implementing 'Store' using
the newtype deriving trick.
-}
newtype MdbxItemStore a = MdbxItemStore {
  MdbxItemStore a -> a
unwrapStore :: a
}

instance Store a => MdbxItem (MdbxItemStore a) where
  fromMdbxVal :: MdbxVal -> IO (MdbxItemStore a)
fromMdbxVal MdbxVal
item = a -> MdbxItemStore a
forall a. a -> MdbxItemStore a
MdbxItemStore (a -> MdbxItemStore a) -> IO a -> IO (MdbxItemStore a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MdbxVal -> IO a
forall v. Store v => MdbxVal -> IO v
fromMdbxStore MdbxVal
item
  toMdbxVal :: MdbxItemStore a -> (MdbxVal -> IO b) -> IO b
toMdbxVal MdbxItemStore a
item = a -> (MdbxVal -> IO b) -> IO b
forall v a. Store v => v -> (MdbxVal -> IO a) -> IO a
withMdbxStore (MdbxItemStore a -> a
forall a. MdbxItemStore a -> a
unwrapStore MdbxItemStore a
item)

-- | Deserializes a 'Store' instance from an 'MdbxVal'.
fromMdbxStore :: Store v => MdbxVal -> IO v
fromMdbxStore :: MdbxVal -> IO v
fromMdbxStore (MdbxVal CULong
size Ptr ()
ptr) = do
  ByteString
bs <- CStringLen -> IO ByteString
unsafePackCStringLen (Ptr () -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
ptr, CULong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULong
size)
  ByteString -> IO v
forall a. Store a => ByteString -> IO a
decodeIO ByteString
bs

-- | Serializes a 'Store' instance to 'MdbxVal', and passes it to a callback.
withMdbxStore :: Store v => v -> (MdbxVal -> IO a) -> IO a
withMdbxStore :: v -> (MdbxVal -> IO a) -> IO a
withMdbxStore v
val MdbxVal -> IO a
fn =
  ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen (v -> ByteString
forall a. Store a => a -> ByteString
encode v
val) ((CStringLen -> IO a) -> IO a) -> (CStringLen -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptrV, Int
sizeV) -> do
    let mval :: MdbxVal
mval = CULong -> Ptr () -> MdbxVal
MdbxVal (Int -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeV) (Ptr CChar -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptrV)
    MdbxVal -> IO a
fn MdbxVal
mval

instance Store NullByteString where
  size :: Size NullByteString
size = (NullByteString -> Int) -> Size NullByteString
forall a. (a -> Int) -> Size a
VarSize
    ((NullByteString -> Int) -> Size NullByteString)
-> (NullByteString -> Int) -> Size NullByteString
forall a b. (a -> b) -> a -> b
$ \NullByteString
bs -> ByteString -> Int
BS.length (ShortByteString -> ByteString
BSH.fromShort (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ NullByteString -> ShortByteString
unNullByteString NullByteString
bs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

  poke :: NullByteString -> Poke ()
poke NullByteString
nbs = do
    let bs :: ByteString
bs = ShortByteString -> ByteString
BSH.fromShort (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ NullByteString -> ShortByteString
unNullByteString NullByteString
nbs
    let (ForeignPtr Word8
sourceFp, Int
sourceOffset, Int
sourceLength) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bs
    ForeignPtr Word8 -> Int -> Int -> Poke ()
forall a. ForeignPtr a -> Int -> Int -> Poke ()
pokeFromForeignPtr ForeignPtr Word8
sourceFp Int
sourceOffset Int
sourceLength
    Word8 -> Poke ()
forall a. Store a => a -> Poke ()
poke (Word8
0 :: Word8)

  peek :: Peek NullByteString
peek = (PeekState -> Ptr Word8 -> IO (PeekResult NullByteString))
-> Peek NullByteString
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult NullByteString))
 -> Peek NullByteString)
-> (PeekState -> Ptr Word8 -> IO (PeekResult NullByteString))
-> Peek NullByteString
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
ptr -> do
    ByteString
bs <- Ptr CChar -> IO ByteString
BS.packCString (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr)
    let newPtr :: Ptr b
newPtr = Ptr Word8
ptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    let nbs :: NullByteString
nbs = ShortByteString -> NullByteString
NullByteString (ByteString -> ShortByteString
BSH.toShort ByteString
bs)
    PeekResult NullByteString -> IO (PeekResult NullByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult NullByteString -> IO (PeekResult NullByteString))
-> PeekResult NullByteString -> IO (PeekResult NullByteString)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> NullByteString -> PeekResult NullByteString
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
forall b. Ptr b
newPtr NullByteString
nbs

instance Store NullText where
  size :: Size NullText
size = (NullText -> Int) -> Size NullText
forall a. (a -> Int) -> Size a
VarSize
    ((NullText -> Int) -> Size NullText)
-> (NullText -> Int) -> Size NullText
forall a b. (a -> b) -> a -> b
$ \NullText
t -> ByteString -> Int
BS.length (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ NullText -> Text
unNullText NullText
t) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

  poke :: NullText -> Poke ()
poke NullText
nt = do
    let bs :: ByteString
bs = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ NullText -> Text
unNullText NullText
nt
    let (ForeignPtr Word8
sourceFp, Int
sourceOffset, Int
sourceLength) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bs
    ForeignPtr Word8 -> Int -> Int -> Poke ()
forall a. ForeignPtr a -> Int -> Int -> Poke ()
pokeFromForeignPtr ForeignPtr Word8
sourceFp Int
sourceOffset Int
sourceLength
    Word8 -> Poke ()
forall a. Store a => a -> Poke ()
poke (Word8
0 :: Word8)

  peek :: Peek NullText
peek = (PeekState -> Ptr Word8 -> IO (PeekResult NullText))
-> Peek NullText
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult NullText))
 -> Peek NullText)
-> (PeekState -> Ptr Word8 -> IO (PeekResult NullText))
-> Peek NullText
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
ptr -> do
    ByteString
bs <- Ptr CChar -> IO ByteString
BS.packCString (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr)
    let newPtr :: Ptr b
newPtr = Ptr Word8
ptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    let nt :: NullText
nt = Text -> NullText
NullText (ByteString -> Text
TE.decodeUtf8 ByteString
bs)
    PeekResult NullText -> IO (PeekResult NullText)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult NullText -> IO (PeekResult NullText))
-> PeekResult NullText -> IO (PeekResult NullText)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> NullText -> PeekResult NullText
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
forall b. Ptr b
newPtr NullText
nt