{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
module RON.Text.Serialize (
serializeAtom,
serializeObject,
serializeRawOp,
serializeStateFrame,
serializeString,
serializeUuid,
serializeWireFrame,
serializeWireFrames,
) where
import RON.Prelude
import Control.Monad.State.Strict (state)
import qualified Data.Aeson as Json
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom,
serializeUuidKey)
import RON.Types (Atom (AFloat, AInteger, AString, AUuid),
ClosedOp (..), ObjectFrame (..), Op (..), Payload,
StateFrame, WireChunk (Closed, Query, Value),
WireFrame, WireReducedChunk (..),
WireStateChunk (..))
import RON.Util (ByteStringL)
import RON.UUID (UUID, zero)
serializeWireFrame :: WireFrame -> ByteStringL
serializeWireFrame chunks
= (`BSLC.snoc` '.')
. fold
. (`evalState` opZero)
$ traverse serializeChunk chunks
serializeWireFrames :: [WireFrame] -> ByteStringL
serializeWireFrames = foldMap serializeWireFrame
serializeChunk :: WireChunk -> State ClosedOp ByteStringL
serializeChunk = \case
Closed op -> (<> " ;\n") <$> serializeClosedOpZip op
Value chunk -> serializeReducedChunk False chunk
Query chunk -> serializeReducedChunk True chunk
serializeReducedChunk :: Bool -> WireReducedChunk -> State ClosedOp ByteStringL
serializeReducedChunk isQuery WireReducedChunk{wrcHeader, wrcBody} =
BSLC.unlines <$> liftA2 (:) serializeHeader serializeBody
where
serializeHeader = do
h <- serializeClosedOpZip wrcHeader
pure $ BSLC.unwords [h, if isQuery then "?" else "!"]
serializeBody = state $ \ClosedOp{op = opBefore, ..} -> let
(body, opAfter) =
(`runState` opBefore) $
for wrcBody $
fmap ("\t" <>) . serializeReducedOpZip objectId
in
( body
, ClosedOp{op = opAfter, ..}
)
serializeRawOp :: ClosedOp -> ByteStringL
serializeRawOp op = evalState (serializeClosedOpZip op) opZero
serializeClosedOpZip :: ClosedOp -> State ClosedOp ByteStringL
serializeClosedOpZip this = state $ \prev -> let
prev' = op prev
typ = serializeUuidKey (reducerId prev) zero (reducerId this)
obj = serializeUuidKey (objectId prev) (reducerId this) (objectId this)
evt = serializeUuidKey (opId prev') (objectId this) (opId this')
ref = serializeUuidKey (refId prev') (opId this') (refId this')
payloadAtoms = serializePayload (objectId this) (payload this')
in
( BSLC.unwords
$ key '*' typ
++ key '#' obj
++ key '@' evt
++ key ':' ref
++ [payloadAtoms | not $ BSL.null payloadAtoms]
, this
)
where
this' = op this
key c u = [BSLC.cons c u | not $ BSL.null u]
serializeReducedOpZip
:: UUID
-> Op
-> State Op ByteStringL
serializeReducedOpZip opObject this = state $ \prev -> let
evt = serializeUuidKey (opId prev) opObject (opId this)
ref = serializeUuidKey (refId prev) (opId this) (refId this)
payloadAtoms = serializePayload opObject (payload this)
in
( BSLC.unwords
$ (if BSL.null evt && BSL.null ref
then ["@"]
else key '@' evt ++ key ':' ref)
++ [payloadAtoms | not $ BSL.null payloadAtoms]
, this
)
where
key c u = [BSLC.cons c u | not $ BSL.null u]
serializeAtom :: Atom -> ByteStringL
serializeAtom a = evalState (serializeAtomZip a) zero
serializeAtomZip :: Atom -> State UUID ByteStringL
serializeAtomZip = \case
AFloat f -> pure $ serializeFloatAtom f
AInteger i -> pure $ serializeIntegerAtom i
AString s -> pure $ serializeString s
AUuid u -> serializeUuidAtom' u
serializeFloatAtom :: Double -> ByteStringL
serializeFloatAtom f = let
s = show f
p = ('.' `List.elem` s || 'e' `List.elem` s || 'E' `List.elem` s)
b = BSLC.pack s
in if p then b
else BSLC.cons '^' b
serializeIntegerAtom :: Int64 -> ByteStringL
serializeIntegerAtom i =
BSLC.pack (show i)
serializeString :: Text -> ByteStringL
serializeString =
wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode
where
wrapSingleQuotes = (`BSLC.snoc` '\'') . BSLC.cons '\''
stripDoubleQuotes = BSL.init . BSL.tail
escapeApostrophe s = let
(s1, s2) = BSLC.break (== '\'') s
in
if BSL.null s2 then
s1
else
s1 <> "\\'" <> escapeApostrophe (BSL.tail s2)
serializeUuidAtom' :: UUID -> State UUID ByteStringL
serializeUuidAtom' u =
state $ \prev -> (BSLC.cons '>' $ serializeUuidAtom prev u, u)
serializePayload
:: UUID
-> Payload
-> ByteStringL
serializePayload prev =
BSLC.unwords . (`evalState` prev) . traverse serializeAtomZip
serializeStateFrame :: StateFrame -> ByteStringL
serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs where
wrapChunk (objectId, WireStateChunk{stateType, stateBody}) =
Value
WireReducedChunk
{ wrcHeader = opZero{reducerId = stateType, objectId}
, wrcBody = stateBody
}
serializeObject :: ObjectFrame a -> (UUID, ByteStringL)
serializeObject (ObjectFrame oid frame) = (oid, serializeStateFrame frame)
opZero :: ClosedOp
opZero = ClosedOp
{ reducerId = zero
, objectId = zero
, op = Op{opId = zero, refId = zero, payload = []}
}