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

-- | RON-Text serialization
module RON.Text.Serialize (
    serializeAtom,
    serializeObject,
    serializeOp,
    serializeOpenOp,
    serializePayload,
    serializeRawOp,
    serializeStateFrame,
    serializeString,
    serializeUuid,
    serializeWireFrame,
    serializeWireFrames,
    uuidToString,
    uuidToText,
    ) where

import           RON.Prelude hiding (elem)

import           Control.Monad.State.Strict (state)
import qualified Data.Aeson as Json
import           Data.ByteString.Lazy.Char8 (cons, elem, snoc)
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Map.Strict as Map

import           RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom,
                                          serializeUuidKey, uuidToString,
                                          uuidToText)
import           RON.Types (Atom (AFloat, AInteger, AString, AUuid),
                            ClosedOp (..), ObjectFrame (..), Op (..), Payload,
                            StateFrame, WireChunk (Closed, Query, Value),
                            WireFrame, WireReducedChunk (..),
                            WireStateChunk (..))
import           RON.UUID (UUID, zero)
import qualified RON.UUID as UUID

-- | Serialize a common frame
serializeWireFrame :: WireFrame -> ByteStringL
serializeWireFrame :: WireFrame -> ByteStringL
serializeWireFrame =
  (ByteStringL -> Char -> ByteStringL
`snoc` Char
'.') (ByteStringL -> ByteStringL)
-> (WireFrame -> ByteStringL) -> WireFrame -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteStringL] -> ByteStringL
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([ByteStringL] -> ByteStringL)
-> (WireFrame -> [ByteStringL]) -> WireFrame -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State ClosedOp [ByteStringL] -> ClosedOp -> [ByteStringL]
forall s a. State s a -> s -> a
`evalState` ClosedOp
opZero) (State ClosedOp [ByteStringL] -> [ByteStringL])
-> (WireFrame -> State ClosedOp [ByteStringL])
-> WireFrame
-> [ByteStringL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WireChunk -> StateT ClosedOp Identity ByteStringL)
-> WireFrame -> State ClosedOp [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse WireChunk -> StateT ClosedOp Identity ByteStringL
serializeChunk

-- | Serialize a sequence of common frames
serializeWireFrames :: [WireFrame] -> ByteStringL
serializeWireFrames :: [WireFrame] -> ByteStringL
serializeWireFrames = (WireFrame -> ByteStringL) -> [WireFrame] -> ByteStringL
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap WireFrame -> ByteStringL
serializeWireFrame

-- | Serialize a common chunk
serializeChunk :: WireChunk -> State ClosedOp ByteStringL
serializeChunk :: WireChunk -> StateT ClosedOp Identity ByteStringL
serializeChunk = \case
  Closed ClosedOp
op -> (ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL
" ;\n") (ByteStringL -> ByteStringL)
-> StateT ClosedOp Identity ByteStringL
-> StateT ClosedOp Identity ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClosedOp -> StateT ClosedOp Identity ByteStringL
serializeClosedOpZip ClosedOp
op
  Value WireReducedChunk
chunk -> Bool -> WireReducedChunk -> StateT ClosedOp Identity ByteStringL
serializeReducedChunk Bool
False WireReducedChunk
chunk
  Query WireReducedChunk
chunk -> Bool -> WireReducedChunk -> StateT ClosedOp Identity ByteStringL
serializeReducedChunk Bool
True WireReducedChunk
chunk

-- | Serialize a reduced chunk
serializeReducedChunk :: Bool -> WireReducedChunk -> State ClosedOp ByteStringL
serializeReducedChunk :: Bool -> WireReducedChunk -> StateT ClosedOp Identity ByteStringL
serializeReducedChunk Bool
isQuery WireReducedChunk {ClosedOp
$sel:wrcHeader:WireReducedChunk :: WireReducedChunk -> ClosedOp
wrcHeader :: ClosedOp
wrcHeader, [Op]
$sel:wrcBody:WireReducedChunk :: WireReducedChunk -> [Op]
wrcBody :: [Op]
wrcBody} =
  [ByteStringL] -> ByteStringL
BSL.unlines ([ByteStringL] -> ByteStringL)
-> State ClosedOp [ByteStringL]
-> StateT ClosedOp Identity ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteStringL -> [ByteStringL] -> [ByteStringL])
-> StateT ClosedOp Identity ByteStringL
-> State ClosedOp [ByteStringL]
-> State ClosedOp [ByteStringL]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) StateT ClosedOp Identity ByteStringL
serializeHeader State ClosedOp [ByteStringL]
serializeBody
  where
    serializeHeader :: StateT ClosedOp Identity ByteStringL
serializeHeader = do
      ByteStringL
h <- ClosedOp -> StateT ClosedOp Identity ByteStringL
serializeClosedOpZip ClosedOp
wrcHeader
      ByteStringL -> StateT ClosedOp Identity ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> StateT ClosedOp Identity ByteStringL)
-> ByteStringL -> StateT ClosedOp Identity ByteStringL
forall a b. (a -> b) -> a -> b
$ ByteStringL -> [ByteStringL] -> ByteStringL
BSL.intercalate ByteStringL
"\t" [ByteStringL
h, if Bool
isQuery then ByteStringL
"?" else ByteStringL
"!"]
    serializeBody :: State ClosedOp [ByteStringL]
serializeBody = (ClosedOp -> ([ByteStringL], ClosedOp))
-> State ClosedOp [ByteStringL]
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((ClosedOp -> ([ByteStringL], ClosedOp))
 -> State ClosedOp [ByteStringL])
-> (ClosedOp -> ([ByteStringL], ClosedOp))
-> State ClosedOp [ByteStringL]
forall a b. (a -> b) -> a -> b
$ \ClosedOp {$sel:op:ClosedOp :: ClosedOp -> Op
op = Op
opBefore, UUID
$sel:objectId:ClosedOp :: ClosedOp -> UUID
$sel:reducerId:ClosedOp :: ClosedOp -> UUID
objectId :: UUID
reducerId :: UUID
..} ->
      let ([ByteStringL]
body, Op
opAfter) =
            (State Op [ByteStringL] -> Op -> ([ByteStringL], Op)
forall s a. State s a -> s -> (a, s)
`runState` Op
opBefore)
              (State Op [ByteStringL] -> ([ByteStringL], Op))
-> State Op [ByteStringL] -> ([ByteStringL], Op)
forall a b. (a -> b) -> a -> b
$ [Op]
-> (Op -> StateT Op Identity ByteStringL) -> State Op [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Op]
wrcBody
              ((Op -> StateT Op Identity ByteStringL) -> State Op [ByteStringL])
-> (Op -> StateT Op Identity ByteStringL) -> State Op [ByteStringL]
forall a b. (a -> b) -> a -> b
$ (ByteStringL -> ByteStringL)
-> StateT Op Identity ByteStringL -> StateT Op Identity ByteStringL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteStringL
"\t" ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<>)
              (StateT Op Identity ByteStringL -> StateT Op Identity ByteStringL)
-> (Op -> StateT Op Identity ByteStringL)
-> Op
-> StateT Op Identity ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Op -> StateT Op Identity ByteStringL
serializeReducedOpZip UUID
objectId
       in ([ByteStringL]
body, ClosedOp :: UUID -> UUID -> Op -> ClosedOp
ClosedOp {$sel:op:ClosedOp :: Op
op = Op
opAfter, UUID
$sel:objectId:ClosedOp :: UUID
$sel:reducerId:ClosedOp :: UUID
objectId :: UUID
reducerId :: UUID
..})

-- | Serialize a context-free raw op
serializeRawOp :: ClosedOp -> ByteStringL
serializeRawOp :: ClosedOp -> ByteStringL
serializeRawOp ClosedOp
op = StateT ClosedOp Identity ByteStringL -> ClosedOp -> ByteStringL
forall s a. State s a -> s -> a
evalState (ClosedOp -> StateT ClosedOp Identity ByteStringL
serializeClosedOpZip ClosedOp
op) ClosedOp
opZero

-- | Serialize a raw op with compression in stream context
serializeClosedOpZip :: ClosedOp -> State ClosedOp ByteStringL
serializeClosedOpZip :: ClosedOp -> StateT ClosedOp Identity ByteStringL
serializeClosedOpZip ClosedOp
this = (ClosedOp -> (ByteStringL, ClosedOp))
-> StateT ClosedOp Identity ByteStringL
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((ClosedOp -> (ByteStringL, ClosedOp))
 -> StateT ClosedOp Identity ByteStringL)
-> (ClosedOp -> (ByteStringL, ClosedOp))
-> StateT ClosedOp Identity ByteStringL
forall a b. (a -> b) -> a -> b
$ \ClosedOp
prev ->
  let prev' :: Op
prev' = ClosedOp -> Op
op ClosedOp
prev
      typ :: ByteStringL
typ = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (ClosedOp -> UUID
reducerId ClosedOp
prev) UUID
zero (ClosedOp -> UUID
reducerId ClosedOp
this)
      obj :: ByteStringL
obj = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (ClosedOp -> UUID
objectId ClosedOp
prev) (ClosedOp -> UUID
reducerId ClosedOp
this) (ClosedOp -> UUID
objectId ClosedOp
this)
      evt :: ByteStringL
evt = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (Op -> UUID
opId Op
prev') (ClosedOp -> UUID
objectId ClosedOp
this) (Op -> UUID
opId Op
this')
      ref :: ByteStringL
ref = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (Op -> UUID
refId Op
prev') (Op -> UUID
opId Op
this') (Op -> UUID
refId Op
this')
      payloadAtoms :: ByteStringL
payloadAtoms = UUID -> Payload -> ByteStringL
serializePayloadZip (ClosedOp -> UUID
objectId ClosedOp
this) (Op -> Payload
payload Op
this')
   in ( ByteStringL -> [ByteStringL] -> ByteStringL
BSL.intercalate ByteStringL
"\t"
          ([ByteStringL] -> ByteStringL) -> [ByteStringL] -> ByteStringL
forall a b. (a -> b) -> a -> b
$  Char -> ByteStringL -> [ByteStringL]
key Char
'*' ByteStringL
typ
          [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ Char -> ByteStringL -> [ByteStringL]
key Char
'#' ByteStringL
obj
          [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ Char -> ByteStringL -> [ByteStringL]
key Char
'@' ByteStringL
evt
          [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ Char -> ByteStringL -> [ByteStringL]
key Char
':' ByteStringL
ref
          [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ [ByteStringL
payloadAtoms | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Bool
BSL.null ByteStringL
payloadAtoms],
        ClosedOp
this
        )
  where
    this' :: Op
this' = ClosedOp -> Op
op ClosedOp
this
    key :: Char -> ByteStringL -> [ByteStringL]
key Char
c ByteStringL
u = [Char
c Char -> ByteStringL -> ByteStringL
`cons` ByteStringL
u | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Bool
BSL.null ByteStringL
u]

-- | Serialize a reduced op with compression in stream context
serializeReducedOpZip
  :: UUID -- ^ enclosing object
  -> Op
  -> State Op ByteStringL
serializeReducedOpZip :: UUID -> Op -> StateT Op Identity ByteStringL
serializeReducedOpZip UUID
opObject Op
this = (Op -> (ByteStringL, Op)) -> StateT Op Identity ByteStringL
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Op -> (ByteStringL, Op)) -> StateT Op Identity ByteStringL)
-> (Op -> (ByteStringL, Op)) -> StateT Op Identity ByteStringL
forall a b. (a -> b) -> a -> b
$ \Op
prev ->
  let evt :: ByteStringL
evt = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (Op -> UUID
opId Op
prev) UUID
opObject (Op -> UUID
opId Op
this)
      ref :: ByteStringL
ref = UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey (Op -> UUID
refId Op
prev) (Op -> UUID
opId Op
this) (Op -> UUID
refId Op
this)
      payloadAtoms :: ByteStringL
payloadAtoms = UUID -> Payload -> ByteStringL
serializePayloadZip UUID
opObject (Op -> Payload
payload Op
this)
      keys :: [ByteStringL]
keys
        | ByteStringL -> Bool
BSL.null ByteStringL
evt Bool -> Bool -> Bool
&& ByteStringL -> Bool
BSL.null ByteStringL
ref = [ByteStringL
"@"]
        | Bool
otherwise = Char -> ByteStringL -> [ByteStringL]
key Char
'@' ByteStringL
evt [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ Char -> ByteStringL -> [ByteStringL]
key Char
':' ByteStringL
ref
      op :: [ByteStringL]
op = [ByteStringL]
keys [ByteStringL] -> [ByteStringL] -> [ByteStringL]
forall a. [a] -> [a] -> [a]
++ [ByteStringL
payloadAtoms | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Bool
BSL.null ByteStringL
payloadAtoms]
   in (ByteStringL -> [ByteStringL] -> ByteStringL
BSL.intercalate ByteStringL
"\t" [ByteStringL]
op, Op
this)
  where
    key :: Char -> ByteStringL -> [ByteStringL]
key Char
c ByteStringL
u = [Char
c Char -> ByteStringL -> ByteStringL
`cons` ByteStringL
u | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Bool
BSL.null ByteStringL
u]

serializeOp :: Op -> ByteStringL
serializeOp :: Op -> ByteStringL
serializeOp Op{UUID
opId :: UUID
$sel:opId:Op :: Op -> UUID
opId, UUID
refId :: UUID
$sel:refId:Op :: Op -> UUID
refId, Payload
payload :: Payload
$sel:payload:Op :: Op -> Payload
payload} =
  ByteStringL -> [ByteStringL] -> ByteStringL
BSL.intercalate ByteStringL
"\t"
    [ Char
'@' Char -> ByteStringL -> ByteStringL
`cons` UUID -> ByteStringL
serializeUuid UUID
opId
    , Char
':' Char -> ByteStringL -> ByteStringL
`cons` UUID -> ByteStringL
serializeUuid UUID
refId
    , UUID -> Payload -> ByteStringL
serializePayloadZip UUID
opId Payload
payload
    ]

serializeOpenOp ::
  -- | Previous op id
  UUID ->
  -- | Current op
  Op ->
  ByteStringL
serializeOpenOp :: UUID -> Op -> ByteStringL
serializeOpenOp UUID
prevId Op{UUID
opId :: UUID
$sel:opId:Op :: Op -> UUID
opId, UUID
refId :: UUID
$sel:refId:Op :: Op -> UUID
refId, Payload
payload :: Payload
$sel:payload:Op :: Op -> Payload
payload} =
  ByteStringL -> [ByteStringL] -> ByteStringL
BSL.intercalate ByteStringL
"\t" ([ByteStringL] -> ByteStringL) -> [ByteStringL] -> ByteStringL
forall a b. (a -> b) -> a -> b
$ ByteStringL
idS ByteStringL -> [ByteStringL] -> [ByteStringL]
forall a. a -> [a] -> [a]
: ByteStringL
refS ByteStringL -> [ByteStringL] -> [ByteStringL]
forall a. a -> [a] -> [a]
: [ByteStringL]
payloadS
  where
    idS :: ByteStringL
idS
      | UUID
opId UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID -> UUID
UUID.succValue UUID
prevId = Char
'@' Char -> ByteStringL -> ByteStringL
`cons` UUID -> ByteStringL
serializeUuid UUID
opId
      | Bool
otherwise                     = ByteStringL
""
    refS :: ByteStringL
refS
      | UUID
refId UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
prevId = Char
':' Char -> ByteStringL -> ByteStringL
`cons` UUID -> ByteStringL
serializeUuid UUID
refId
      | Bool
otherwise       = ByteStringL
""
    payloadS :: [ByteStringL]
payloadS = [UUID -> Payload -> ByteStringL
serializePayloadZip UUID
opId Payload
payload | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Payload -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Payload
payload]

-- | Serialize a context-free atom
serializeAtom :: Atom -> ByteStringL
serializeAtom :: Atom -> ByteStringL
serializeAtom Atom
a = State UUID ByteStringL -> UUID -> ByteStringL
forall s a. State s a -> s -> a
evalState (Atom -> State UUID ByteStringL
serializeAtomZip Atom
a) UUID
zero

-- | Serialize an atom with compression for UUID in stream context
serializeAtomZip :: Atom -> State UUID ByteStringL
serializeAtomZip :: Atom -> State UUID ByteStringL
serializeAtomZip = \case
  AFloat Double
f -> ByteStringL -> State UUID ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> State UUID ByteStringL)
-> ByteStringL -> State UUID ByteStringL
forall a b. (a -> b) -> a -> b
$ Double -> ByteStringL
serializeFloatAtom Double
f
  AInteger Int64
i -> ByteStringL -> State UUID ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> State UUID ByteStringL)
-> ByteStringL -> State UUID ByteStringL
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteStringL
serializeIntegerAtom Int64
i
  AString Text
s -> ByteStringL -> State UUID ByteStringL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStringL -> State UUID ByteStringL)
-> ByteStringL -> State UUID ByteStringL
forall a b. (a -> b) -> a -> b
$ Text -> ByteStringL
serializeString Text
s
  AUuid UUID
u -> UUID -> State UUID ByteStringL
serializeUuidAtom' UUID
u

-- | Serialize a float atom.
-- If unambiguous, i.e. contains a '.' or an 'e'/'E', the prefix '^' is skipped.
serializeFloatAtom :: Double -> ByteStringL
serializeFloatAtom :: Double -> ByteStringL
serializeFloatAtom Double
float
  | Bool
isDistinguishableFromUuid = ByteStringL
bs
  | Bool
otherwise = Char
'^' Char -> ByteStringL -> ByteStringL
`cons` ByteStringL
bs
  where
    isDistinguishableFromUuid :: Bool
isDistinguishableFromUuid = Char
'.' Char -> ByteStringL -> Bool
`elem` ByteStringL
bs Bool -> Bool -> Bool
|| Char
'e' Char -> ByteStringL -> Bool
`elem` ByteStringL
bs Bool -> Bool -> Bool
|| Char
'E' Char -> ByteStringL -> Bool
`elem` ByteStringL
bs
    bs :: ByteStringL
bs = [Char] -> ByteStringL
BSL.pack ([Char] -> ByteStringL) -> [Char] -> ByteStringL
forall a b. (a -> b) -> a -> b
$ Double -> [Char]
forall a s. (Show a, IsString s) => a -> s
show Double
float

-- | Serialize an integer atom.
-- Since integers are always unambiguous, the prefix '=' is always skipped.
serializeIntegerAtom :: Int64 -> ByteStringL
serializeIntegerAtom :: Int64 -> ByteStringL
serializeIntegerAtom = [Char] -> ByteStringL
BSL.pack ([Char] -> ByteStringL)
-> (Int64 -> [Char]) -> Int64 -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> [Char]
forall a s. (Show a, IsString s) => a -> s
show

-- | Serialize a string atom
serializeString :: Text -> ByteStringL
serializeString :: Text -> ByteStringL
serializeString =
  ByteStringL -> ByteStringL
wrapSingleQuotes (ByteStringL -> ByteStringL)
-> (Text -> ByteStringL) -> Text -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringL -> ByteStringL
escapeApostrophe (ByteStringL -> ByteStringL)
-> (Text -> ByteStringL) -> Text -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringL -> ByteStringL
stripDoubleQuotes (ByteStringL -> ByteStringL)
-> (Text -> ByteStringL) -> Text -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteStringL
forall a. ToJSON a => a -> ByteStringL
Json.encode
  where
    wrapSingleQuotes :: ByteStringL -> ByteStringL
wrapSingleQuotes = (ByteStringL -> Char -> ByteStringL
`snoc` Char
'\'') (ByteStringL -> ByteStringL)
-> (ByteStringL -> ByteStringL) -> ByteStringL -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteStringL -> ByteStringL
cons Char
'\''
    stripDoubleQuotes :: ByteStringL -> ByteStringL
stripDoubleQuotes = ByteStringL -> ByteStringL
BSL.init (ByteStringL -> ByteStringL)
-> (ByteStringL -> ByteStringL) -> ByteStringL -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringL -> ByteStringL
BSL.tail
    escapeApostrophe :: ByteStringL -> ByteStringL
escapeApostrophe ByteStringL
s
      | ByteStringL -> Bool
BSL.null ByteStringL
s2 = ByteStringL
s1
      | Bool
otherwise = ByteStringL
s1 ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL
"\\'" ByteStringL -> ByteStringL -> ByteStringL
forall a. Semigroup a => a -> a -> a
<> ByteStringL -> ByteStringL
escapeApostrophe (ByteStringL -> ByteStringL
BSL.tail ByteStringL
s2)
      where
        (ByteStringL
s1, ByteStringL
s2) = (Char -> Bool) -> ByteStringL -> (ByteStringL, ByteStringL)
BSL.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'') ByteStringL
s

serializeUuidAtom' :: UUID -> State UUID ByteStringL
serializeUuidAtom' :: UUID -> State UUID ByteStringL
serializeUuidAtom' UUID
u =
  -- TODO(2019-08-19, cblp): Check if uuid can be unambiguously serialized and
  -- if so, skip the prefix.
  (UUID -> (ByteStringL, UUID)) -> State UUID ByteStringL
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((UUID -> (ByteStringL, UUID)) -> State UUID ByteStringL)
-> (UUID -> (ByteStringL, UUID)) -> State UUID ByteStringL
forall a b. (a -> b) -> a -> b
$ \UUID
prev -> (Char -> ByteStringL -> ByteStringL
cons Char
'>' (ByteStringL -> ByteStringL) -> ByteStringL -> ByteStringL
forall a b. (a -> b) -> a -> b
$ UUID -> UUID -> ByteStringL
serializeUuidAtom UUID
prev UUID
u, UUID
u)

-- | Serialize a payload in stream context
serializePayloadZip
  :: UUID -- ^ previous UUID (default is 'zero')
  -> Payload
  -> ByteStringL
serializePayloadZip :: UUID -> Payload -> ByteStringL
serializePayloadZip UUID
prev =
  [ByteStringL] -> ByteStringL
BSL.unwords ([ByteStringL] -> ByteStringL)
-> (Payload -> [ByteStringL]) -> Payload -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State UUID [ByteStringL] -> UUID -> [ByteStringL]
forall s a. State s a -> s -> a
`evalState` UUID
prev) (State UUID [ByteStringL] -> [ByteStringL])
-> (Payload -> State UUID [ByteStringL])
-> Payload
-> [ByteStringL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Atom -> State UUID ByteStringL)
-> Payload -> State UUID [ByteStringL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom -> State UUID ByteStringL
serializeAtomZip

-- | Serialize an abstract payload
serializePayload :: Payload -> ByteStringL
serializePayload :: Payload -> ByteStringL
serializePayload = UUID -> Payload -> ByteStringL
serializePayloadZip UUID
UUID.zero

-- | Serialize a state frame
serializeStateFrame :: StateFrame -> ByteStringL
serializeStateFrame :: StateFrame -> ByteStringL
serializeStateFrame = WireFrame -> ByteStringL
serializeWireFrame (WireFrame -> ByteStringL)
-> (StateFrame -> WireFrame) -> StateFrame -> ByteStringL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UUID, WireStateChunk) -> WireChunk)
-> [(UUID, WireStateChunk)] -> WireFrame
forall a b. (a -> b) -> [a] -> [b]
map (UUID, WireStateChunk) -> WireChunk
wrapChunk ([(UUID, WireStateChunk)] -> WireFrame)
-> (StateFrame -> [(UUID, WireStateChunk)])
-> StateFrame
-> WireFrame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateFrame -> [(UUID, WireStateChunk)]
forall k a. Map k a -> [(k, a)]
Map.assocs
  where
    wrapChunk :: (UUID, WireStateChunk) -> WireChunk
wrapChunk (UUID
objectId, WireStateChunk {UUID
$sel:stateType:WireStateChunk :: WireStateChunk -> UUID
stateType :: UUID
stateType, [Op]
$sel:stateBody:WireStateChunk :: WireStateChunk -> [Op]
stateBody :: [Op]
stateBody}) =
      WireReducedChunk -> WireChunk
Value WireReducedChunk :: ClosedOp -> [Op] -> WireReducedChunk
WireReducedChunk
        { $sel:wrcHeader:WireReducedChunk :: ClosedOp
wrcHeader = ClosedOp
opZero {$sel:reducerId:ClosedOp :: UUID
reducerId = UUID
stateType, UUID
objectId :: UUID
$sel:objectId:ClosedOp :: UUID
objectId},
          $sel:wrcBody:WireReducedChunk :: [Op]
wrcBody = [Op]
stateBody
          }

-- | Serialize an object. Return object id that must be stored separately.
serializeObject :: ObjectFrame a -> (UUID, ByteStringL)
serializeObject :: ObjectFrame a -> (UUID, ByteStringL)
serializeObject (ObjectFrame UUID
oid StateFrame
frame) = (UUID
oid, StateFrame -> ByteStringL
serializeStateFrame StateFrame
frame)

opZero :: ClosedOp
opZero :: ClosedOp
opZero = ClosedOp :: UUID -> UUID -> Op -> ClosedOp
ClosedOp
  { $sel:reducerId:ClosedOp :: UUID
reducerId = UUID
zero
  , $sel:objectId:ClosedOp :: UUID
objectId  = UUID
zero
  , $sel:op:ClosedOp :: Op
op        = Op :: UUID -> UUID -> Payload -> Op
Op{$sel:opId:Op :: UUID
opId = UUID
zero, $sel:refId:Op :: UUID
refId = UUID
zero, $sel:payload:Op :: Payload
payload = []}
  }