{-|
Module      : Mdbx.Binary
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 'Binary' instances.
-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}

module Mdbx.Binary (
  MdbxItemBinary(..)
) where

import Control.Monad (forM_)
import Data.Binary
import Data.Binary.Get (getLazyByteStringNul)
import Foreign.Ptr (castPtr)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as BSH
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Unsafe as BSU
import qualified Data.Text.Encoding as TE

import Mdbx.Types

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

instance Binary a => MdbxItem (MdbxItemBinary a) where
  fromMdbxVal :: MdbxVal -> IO (MdbxItemBinary a)
fromMdbxVal MdbxVal
item = a -> MdbxItemBinary a
forall a. a -> MdbxItemBinary a
MdbxItemBinary (a -> MdbxItemBinary a) -> IO a -> IO (MdbxItemBinary a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MdbxVal -> IO a
forall v. Binary v => MdbxVal -> IO v
fromMdbxBinary MdbxVal
item
  toMdbxVal :: MdbxItemBinary a -> (MdbxVal -> IO b) -> IO b
toMdbxVal MdbxItemBinary a
item = a -> (MdbxVal -> IO b) -> IO b
forall v a. Binary v => v -> (MdbxVal -> IO a) -> IO a
withMdbxBinary (MdbxItemBinary a -> a
forall a. MdbxItemBinary a -> a
unwrapBinary MdbxItemBinary a
item)

-- | Deserializes a 'Binary' instance from an 'MdbxVal'.
fromMdbxBinary :: Binary v => MdbxVal -> IO v
fromMdbxBinary :: MdbxVal -> IO v
fromMdbxBinary (MdbxVal CULong
size Ptr ()
ptr) = do
  ByteString
bs <- CStringLen -> IO ByteString
BSU.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)
  v -> IO v
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> IO v) -> v -> IO v
forall a b. (a -> b) -> a -> b
$ ByteString -> v
forall a. Binary a => ByteString -> a
decode (ByteString -> ByteString
BSL.fromStrict ByteString
bs)

-- | Serializes a 'Binary' instance to 'MdbxVal', and passes it to a callback.
withMdbxBinary :: Binary v => v -> (MdbxVal -> IO a) -> IO a
withMdbxBinary :: v -> (MdbxVal -> IO a) -> IO a
withMdbxBinary v
val MdbxVal -> IO a
fn =
  ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen (ByteString -> ByteString
BSL.toStrict (v -> ByteString
forall a. Binary 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 Binary NullByteString where
  put :: NullByteString -> Put
put NullByteString
nbs = do
    [Word8] -> (Word8 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ShortByteString -> [Word8]
BSH.unpack (ShortByteString -> [Word8]) -> ShortByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ NullByteString -> ShortByteString
unNullByteString NullByteString
nbs) Word8 -> Put
putWord8
    Word8 -> Put
putWord8 Word8
0

  get :: Get NullByteString
get = ShortByteString -> NullByteString
NullByteString (ShortByteString -> NullByteString)
-> (ByteString -> ShortByteString) -> ByteString -> NullByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
BSH.toShort (ByteString -> ShortByteString)
-> (ByteString -> ByteString) -> ByteString -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> NullByteString)
-> Get ByteString -> Get NullByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul

deriving via (MdbxItemBinary NullByteString) instance MdbxItem NullByteString

instance Binary NullText where
  put :: NullText -> Put
put NullText
nbs = do
    [Word8] -> (Word8 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> (Text -> ByteString) -> Text -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> [Word8]) -> Text -> [Word8]
forall a b. (a -> b) -> a -> b
$ NullText -> Text
unNullText NullText
nbs) Word8 -> Put
putWord8
    Word8 -> Put
putWord8 Word8
0

  get :: Get NullText
get = Text -> NullText
NullText (Text -> NullText)
-> (ByteString -> Text) -> ByteString -> NullText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> NullText) -> Get ByteString -> Get NullText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul

deriving via (MdbxItemBinary NullText) instance MdbxItem NullText