{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Binary serializer elements
module RON.Binary.Serialize (
    serialize,
    serializeAtom,
    serializeString,
) where

import           RON.Prelude

import qualified Data.Binary as Binary
import           Data.Binary.Put (putDoublebe, runPut)
import           Data.Bits (bit, shiftL, (.|.))
import           Data.ByteString.Lazy (cons, fromStrict)
import qualified Data.ByteString.Lazy as BSL
import           Data.Text.Encoding (encodeUtf8)
import           Data.ZigZag (zzEncode)

import           RON.Binary.Types (Desc (..), Size, descIsOp)
import           RON.Types (Atom (AFloat, AInteger, AString, AUuid),
                            ClosedOp (..), Op (..), UUID (UUID),
                            WireChunk (Closed, Query, Value), WireFrame,
                            WireReducedChunk (..))
import           RON.Util.Word (Word4, b0000, leastSignificant4, safeCast)

-- | Serialize a frame
serialize :: WireFrame -> Either String ByteStringL
serialize :: WireFrame -> Either String ByteStringL
serialize WireFrame
chunks = (ByteStringL
"RON2" ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<>) (ByteStringL -> ByteStringL)
-> Either String ByteStringL -> Either String ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String ByteStringL
serializeBody
  where
    serializeBody :: Either String ByteStringL
serializeBody = [ByteStringL] -> Either String ByteStringL
foldChunks ([ByteStringL] -> Either String ByteStringL)
-> Either String [ByteStringL] -> Either String ByteStringL
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (WireChunk -> Either String ByteStringL)
-> WireFrame -> Either String [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse WireChunk -> Either String ByteStringL
serializeChunk WireFrame
chunks

    chunkSize :: Bool -> Int64 -> Either String ByteStringL
    chunkSize :: Bool -> Int64 -> Either String ByteStringL
chunkSize Bool
continue Int64
x
        | Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int64
forall a. Bits a => Int -> a
bit Int
31 = ByteStringL -> Either String ByteStringL
forall a b. b -> Either a b
Right (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ Size -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode Size
s'
        | Bool
otherwise  = String -> Either String ByteStringL
forall a b. a -> Either a b
Left (String -> Either String ByteStringL)
-> String -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ String
"chunk size is too big: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a s. (Show a, IsString s) => a -> s
show Int64
x
      where
        s :: Size
s = Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x :: Size
        s' :: Size
s'  | Bool
continue  = Size
s Size -> Size -> Size
forall a. Bits a => a -> a -> a
.|. Int -> Size
forall a. Bits a => Int -> a
bit Int
31
            | Bool
otherwise = Size
s

    foldChunks :: [ByteStringL] -> Either String ByteStringL
    foldChunks :: [ByteStringL] -> Either String ByteStringL
foldChunks = \case
        []   -> Bool -> Int64 -> Either String ByteStringL
chunkSize Bool
False Int64
0
        [ByteStringL
c]  -> (ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL
c) (ByteStringL -> ByteStringL)
-> Either String ByteStringL -> Either String ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Int64 -> Either String ByteStringL
chunkSize Bool
False (ByteStringL -> Int64
BSL.length ByteStringL
c)
        ByteStringL
c:[ByteStringL]
cs ->
            [ByteStringL] -> ByteStringL
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([ByteStringL] -> ByteStringL)
-> Either String [ByteStringL] -> Either String ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [Either String ByteStringL] -> Either String [ByteStringL]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Bool -> Int64 -> Either String ByteStringL
chunkSize Bool
True (ByteStringL -> Int64
BSL.length ByteStringL
c), ByteStringL -> Either String ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteStringL
c, [ByteStringL] -> Either String ByteStringL
foldChunks [ByteStringL]
cs]

-- | Serialize a chunk
serializeChunk :: WireChunk -> Either String ByteStringL
serializeChunk :: WireChunk -> Either String ByteStringL
serializeChunk = \case
    Closed ClosedOp
op    -> Desc -> ClosedOp -> Either String ByteStringL
serializeClosedOp Desc
DOpClosed ClosedOp
op
    Value WireReducedChunk
rchunk -> Bool -> WireReducedChunk -> Either String ByteStringL
serializeReducedChunk Bool
False WireReducedChunk
rchunk
    Query WireReducedChunk
rchunk -> Bool -> WireReducedChunk -> Either String ByteStringL
serializeReducedChunk Bool
True  WireReducedChunk
rchunk

-- | Serialize a closed op
serializeClosedOp :: Desc -> ClosedOp -> Either String ByteStringL
serializeClosedOp :: Desc -> ClosedOp -> Either String ByteStringL
serializeClosedOp Desc
desc ClosedOp{UUID
Op
$sel:op:ClosedOp :: ClosedOp -> Op
$sel:objectId:ClosedOp :: ClosedOp -> UUID
$sel:reducerId:ClosedOp :: ClosedOp -> UUID
op :: Op
objectId :: UUID
reducerId :: UUID
..} = do
    [ByteStringL]
keys <- [Either String ByteStringL] -> Either String [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ UUID -> Either String ByteStringL
serializeUuidReducer UUID
reducerId
        , UUID -> Either String ByteStringL
serializeUuidObject  UUID
objectId
        , UUID -> Either String ByteStringL
serializeUuidOpId    UUID
opId
        , UUID -> Either String ByteStringL
serializeUuidRef     UUID
refId
        ]
    [ByteStringL]
payloadValue <- (Atom -> Either String ByteStringL)
-> [Atom] -> Either String [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom -> Either String ByteStringL
serializeAtom [Atom]
payload
    Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
desc (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ [ByteStringL] -> ByteStringL
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([ByteStringL] -> ByteStringL) -> [ByteStringL] -> ByteStringL
forall a b. (a -> b) -> a -> b
$ [ByteStringL]
keys [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ [ByteStringL]
payloadValue
  where
    Op{UUID
$sel:opId:Op :: Op -> UUID
opId :: UUID
opId, UUID
$sel:refId:Op :: Op -> UUID
refId :: UUID
refId, [Atom]
$sel:payload:Op :: Op -> [Atom]
payload :: [Atom]
payload} = Op
op
    serializeUuidReducer :: UUID -> Either String ByteStringL
serializeUuidReducer = Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DUuidReducer (ByteStringL -> Either String ByteStringL)
-> (UUID -> ByteStringL) -> UUID -> Either String ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteStringL
serializeUuid
    serializeUuidObject :: UUID -> Either String ByteStringL
serializeUuidObject  = Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DUuidObject  (ByteStringL -> Either String ByteStringL)
-> (UUID -> ByteStringL) -> UUID -> Either String ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteStringL
serializeUuid
    serializeUuidOpId :: UUID -> Either String ByteStringL
serializeUuidOpId    = Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DUuidOp      (ByteStringL -> Either String ByteStringL)
-> (UUID -> ByteStringL) -> UUID -> Either String ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteStringL
serializeUuid
    serializeUuidRef :: UUID -> Either String ByteStringL
serializeUuidRef     = Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DUuidRef     (ByteStringL -> Either String ByteStringL)
-> (UUID -> ByteStringL) -> UUID -> Either String ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteStringL
serializeUuid

-- | Serialize a reduced op
serializeReducedOp :: Desc -> UUID -> UUID -> Op -> Either String ByteStringL
serializeReducedOp :: Desc -> UUID -> UUID -> Op -> Either String ByteStringL
serializeReducedOp Desc
d UUID
reducerId UUID
objectId Op
op =
    Desc -> ClosedOp -> Either String ByteStringL
serializeClosedOp Desc
d ClosedOp :: UUID -> UUID -> Op -> ClosedOp
ClosedOp{UUID
reducerId :: UUID
$sel:reducerId:ClosedOp :: UUID
reducerId, UUID
objectId :: UUID
$sel:objectId:ClosedOp :: UUID
objectId, Op
op :: Op
$sel:op:ClosedOp :: Op
op}

-- | Serialize a 'UUID'
serializeUuid :: UUID -> ByteStringL
serializeUuid :: UUID -> ByteStringL
serializeUuid (UUID Word64
x Word64
y) = Word64 -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode Word64
x ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode Word64
y

-- | Encode descriptor
encodeDesc :: Desc -> Word4
encodeDesc :: Desc -> Word4
encodeDesc = Int -> Word4
forall integral. Integral integral => integral -> Word4
leastSignificant4 (Int -> Word4) -> (Desc -> Int) -> Desc -> Word4
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Desc -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Prepend serialized bytes with descriptor
serializeWithDesc
    :: Desc
    -> ByteStringL  -- ^ body
    -> Either String ByteStringL
serializeWithDesc :: Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
d ByteStringL
body = do
    (Word4
lengthDesc, ByteStringL
lengthExtended) <- Either String (Word4, ByteStringL)
lengthFields
    let descByte :: Word8
descByte = Word4 -> Word8
forall v w. SafeCast v w => v -> w
safeCast (Desc -> Word4
encodeDesc Desc
d) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word4 -> Word8
forall v w. SafeCast v w => v -> w
safeCast Word4
lengthDesc
    ByteStringL -> Either String ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ Word8
descByte Word8 -> ByteStringL -> ByteStringL
`cons` ByteStringL
lengthExtended ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL
body
  where
    len :: Int64
len = ByteStringL -> Int64
BSL.length ByteStringL
body
    lengthFields :: Either String (Word4, ByteStringL)
lengthFields = case Desc
d of
        Desc
DAtomString
            | Int64
len Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0     -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Word4
b0000, ByteStringL
mkLengthExtended)
            | Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
16     -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Int64 -> Word4
forall integral. Integral integral => integral -> Word4
leastSignificant4 Int64
len, ByteStringL
BSL.empty)
            | Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int64
forall a. Bits a => Int -> a
bit Int
31 -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Word4
b0000, ByteStringL
mkLengthExtended)
            | Bool
otherwise    -> String -> Either String (Word4, ByteStringL)
forall a b. a -> Either a b
Left String
"String is too long"
        Desc
_
            | Desc -> Bool
descIsOp Desc
d   -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Word4
b0000, ByteStringL
BSL.empty)
            | Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
16     -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Int64 -> Word4
forall integral. Integral integral => integral -> Word4
leastSignificant4 Int64
len, ByteStringL
BSL.empty)
            | Int64
len Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
16    -> (Word4, ByteStringL) -> Either String (Word4, ByteStringL)
forall a b. b -> Either a b
Right (Word4
b0000, ByteStringL
BSL.empty)
            | Bool
otherwise    -> String -> Either String (Word4, ByteStringL)
forall a b. a -> Either a b
Left String
"impossible"
    mkLengthExtended :: ByteStringL
mkLengthExtended
        | Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
128 = Word8 -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode (Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len :: Word8)
        | Bool
otherwise = Size -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode (Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len Size -> Size -> Size
forall a. Bits a => a -> a -> a
.|. Int -> Size
forall a. Bits a => Int -> a
bit Int
31 :: Word32)

-- | Serialize an 'Atom'
serializeAtom :: Atom -> Either String ByteStringL
serializeAtom :: Atom -> Either String ByteStringL
serializeAtom = \case
    AFloat   Double
f -> Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DAtomFloat   (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ Double -> ByteStringL
serializeFloat Double
f
    AInteger Int64
i -> Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DAtomInteger (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ Word64 -> ByteStringL
forall a. Binary a => a -> ByteStringL
Binary.encode (Word64 -> ByteStringL) -> Word64 -> ByteStringL
forall a b. (a -> b) -> a -> b
$ Int64 -> Word64
zzEncode64 Int64
i
    AString  Text
s -> Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DAtomString  (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ Text -> ByteStringL
serializeString Text
s
    AUuid    UUID
u -> Desc -> ByteStringL -> Either String ByteStringL
serializeWithDesc Desc
DAtomUuid    (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ UUID -> ByteStringL
serializeUuid UUID
u
  where
    {-# INLINE zzEncode64 #-}
    zzEncode64 :: Int64 -> Word64
    zzEncode64 :: Int64 -> Word64
zzEncode64 = Int64 -> Word64
forall b a. (Num b, Integral a, FiniteBits a) => a -> b
zzEncode

-- | Serialize a float atom
serializeFloat :: Double -> ByteStringL
serializeFloat :: Double -> ByteStringL
serializeFloat = Put -> ByteStringL
runPut (Put -> ByteStringL) -> (Double -> Put) -> Double -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Put
putDoublebe

-- | Serialize a reduced chunk
serializeReducedChunk :: Bool -> WireReducedChunk -> Either String ByteStringL
serializeReducedChunk :: Bool -> WireReducedChunk -> Either String ByteStringL
serializeReducedChunk Bool
isQuery WireReducedChunk{[Op]
ClosedOp
$sel:wrcBody:WireReducedChunk :: WireReducedChunk -> [Op]
$sel:wrcHeader:WireReducedChunk :: WireReducedChunk -> ClosedOp
wrcBody :: [Op]
wrcHeader :: ClosedOp
..} = do
    ByteStringL
header <-
        Desc -> ClosedOp -> Either String ByteStringL
serializeClosedOp (if Bool
isQuery then Desc
DOpQueryHeader else Desc
DOpHeader) ClosedOp
wrcHeader
    ByteStringL
body <- (Op -> Either String ByteStringL)
-> [Op] -> Either String ByteStringL
forall b (f :: * -> *) (t :: * -> *) a.
(Monoid b, Applicative f, Foldable t) =>
(a -> f b) -> t a -> f b
foldMapA (Desc -> UUID -> UUID -> Op -> Either String ByteStringL
serializeReducedOp Desc
DOpReduced UUID
reducerId UUID
objectId) [Op]
wrcBody
    ByteStringL -> Either String ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> Either String ByteStringL)
-> ByteStringL -> Either String ByteStringL
forall a b. (a -> b) -> a -> b
$ ByteStringL
header ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL
body
  where
    ClosedOp{UUID
Op
op :: Op
objectId :: UUID
reducerId :: UUID
$sel:op:ClosedOp :: ClosedOp -> Op
$sel:objectId:ClosedOp :: ClosedOp -> UUID
$sel:reducerId:ClosedOp :: ClosedOp -> UUID
..} = ClosedOp
wrcHeader

-- | Serialize a string atom
serializeString :: Text -> ByteStringL
serializeString :: Text -> ByteStringL
serializeString = ByteString -> ByteStringL
fromStrict (ByteString -> ByteStringL)
-> (Text -> ByteString) -> Text -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

foldMapA :: (Monoid b, Applicative f, Foldable t) => (a -> f b) -> t a -> f b
foldMapA :: (a -> f b) -> t a -> f b
foldMapA a -> f b
f = ([b] -> b) -> f [b] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> b
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (f [b] -> f b) -> (t a -> f [b]) -> t a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f ([a] -> f [b]) -> (t a -> [a]) -> t a -> f [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList