{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

-- | Binary parser elements
module RON.Binary.Parse (
    parse,
    parseAtom,
    parseString,
) where

import           RON.Prelude

import           Attoparsec.Extra (Parser, anyWord8, endOfInputEx, label,
                                   parseOnlyL, takeL, withInputSize)
import qualified Attoparsec.Extra as Atto
import qualified Data.Binary as Binary
import           Data.Binary.Get (getDoublebe, runGet)
import           Data.Bits (shiftR, testBit, (.&.))
import           Data.ByteString.Lazy (cons, toStrict)
import qualified Data.ByteString.Lazy as BSL
import           Data.Text.Encoding (decodeUtf8)
import           Data.ZigZag (zzDecode64)

import           RON.Binary.Types (Desc (..), Size, descIsOp)
import           RON.Types (Atom (AFloat, AInteger, AString, AUuid),
                            ClosedOp (..), Op (..),
                            OpTerm (TClosed, THeader, TQuery, TReduced),
                            Payload, UUID (UUID),
                            WireChunk (Closed, Query, Value), WireFrame,
                            WireReducedChunk (..))
import           RON.Util.Word (safeCast)

-- | 'Parser' for descriptor
parseDesc :: Parser (Desc, Size)
parseDesc :: Parser (Desc, Size)
parseDesc = String -> Parser (Desc, Size) -> Parser (Desc, Size)
forall a. String -> Parser a -> Parser a
label String
"desc" (Parser (Desc, Size) -> Parser (Desc, Size))
-> Parser (Desc, Size) -> Parser (Desc, Size)
forall a b. (a -> b) -> a -> b
$ do
    Word8
b <- String -> Parser Word8 -> Parser Word8
forall a. String -> Parser a -> Parser a
label String
"start byte" Parser Word8
anyWord8
    let typeCode :: Word8
typeCode = Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4
    let sizeCode :: Word8
sizeCode = Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b1111
    let desc :: Desc
desc = Int -> Desc
forall a. Enum a => Int -> a
toEnum (Int -> Desc) -> Int -> Desc
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
typeCode
    Size
size <- case (Word8
sizeCode, Desc
desc) of
        (Word8
0, Desc
DAtomString)    -> Parser ByteString Size
extendedLength
        (Word8
0, Desc
d) | Desc -> Bool
descIsOp Desc
d -> Size -> Parser ByteString Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure Size
0
        (Word8
0, Desc
_)              -> Size -> Parser ByteString Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure Size
16
        (Word8, Desc)
_                   -> Size -> Parser ByteString Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> Parser ByteString Size) -> Size -> Parser ByteString Size
forall a b. (a -> b) -> a -> b
$ Word8 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
sizeCode
    (Desc, Size) -> Parser (Desc, Size)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Desc
desc, Size
size)

-- | 'Parser' for extended length field
extendedLength :: Parser Size
extendedLength :: Parser ByteString Size
extendedLength = do
    Word8
b <- Parser Word8
anyWord8
    if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
b Int
7 then do
        ByteStringL
bbb <- Int -> Parser ByteStringL
takeL Int
3
        Size -> Parser ByteString Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> Parser ByteString Size) -> Size -> Parser ByteString Size
forall a b. (a -> b) -> a -> b
$ Size -> Size
leastSignificant31 (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Size
forall a. Binary a => ByteStringL -> a
Binary.decode (Word8
b Word8 -> ByteStringL -> ByteStringL
`cons` ByteStringL
bbb)
    else
        Size -> Parser ByteString Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> Parser ByteString Size) -> Size -> Parser ByteString Size
forall a b. (a -> b) -> a -> b
$ Word8 -> Size
forall v w. SafeCast v w => v -> w
safeCast Word8
b

-- | Parse frame
parse :: ByteStringL -> Either String WireFrame
parse :: ByteStringL -> Either String WireFrame
parse = Parser WireFrame -> ByteStringL -> Either String WireFrame
forall a. Parser a -> ByteStringL -> Either String a
parseOnlyL (Parser WireFrame -> ByteStringL -> Either String WireFrame)
-> Parser WireFrame -> ByteStringL -> Either String WireFrame
forall a b. (a -> b) -> a -> b
$ Parser WireFrame
parseFrame Parser WireFrame -> Parser ByteString () -> Parser WireFrame
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfInputEx

-- | 'Parser' for frame
parseFrame :: Parser WireFrame
parseFrame :: Parser WireFrame
parseFrame = String -> Parser WireFrame -> Parser WireFrame
forall a. String -> Parser a -> Parser a
label String
"WireFrame" (Parser WireFrame -> Parser WireFrame)
-> Parser WireFrame -> Parser WireFrame
forall a b. (a -> b) -> a -> b
$ do
    ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"RON2" Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
        ByteStringL
magic <- Int -> Parser ByteStringL
takeL Int
4
        String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString) -> String -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ String
"unsupported magic sequence " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteStringL -> String
forall a s. (Show a, IsString s) => a -> s
show ByteStringL
magic
    Parser WireFrame
parseChunks

-- | 'Parser' for chunk sequence
parseChunks :: Parser [WireChunk]
parseChunks :: Parser WireFrame
parseChunks = do
    Size
size :: Size <- ByteStringL -> Size
forall a. Binary a => ByteStringL -> a
Binary.decode (ByteStringL -> Size)
-> Parser ByteStringL -> Parser ByteString Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL Int
4
    if  | Size -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Size
size Int
31 ->
            (WireChunk -> WireFrame -> WireFrame)
-> Parser ByteString WireChunk
-> Parser WireFrame
-> Parser WireFrame
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (Size -> Parser ByteString WireChunk
parseChunk (Size -> Parser ByteString WireChunk)
-> Size -> Parser ByteString WireChunk
forall a b. (a -> b) -> a -> b
$ Size -> Size
leastSignificant31 Size
size) Parser WireFrame
parseChunks
        | Size
size Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ->
            (WireChunk -> WireFrame -> WireFrame
forall a. a -> [a] -> [a]
:[]) (WireChunk -> WireFrame)
-> Parser ByteString WireChunk -> Parser WireFrame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Parser ByteString WireChunk
parseChunk Size
size
        | Bool
True ->
            WireFrame -> Parser WireFrame
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Clear upper bit of 'Word32'
leastSignificant31 :: Word32 -> Word32
leastSignificant31 :: Size -> Size
leastSignificant31 Size
x = Size
x Size -> Size -> Size
forall a. Bits a => a -> a -> a
.&. Size
0x7FFFFFFF

-- | 'Parser' for a chunk
parseChunk
    :: Size  -- ^ expected input length
    -> Parser WireChunk
parseChunk :: Size -> Parser ByteString WireChunk
parseChunk Size
size = String
-> Parser ByteString WireChunk -> Parser ByteString WireChunk
forall a. String -> Parser a -> Parser a
label String
"WireChunk" (Parser ByteString WireChunk -> Parser ByteString WireChunk)
-> Parser ByteString WireChunk -> Parser ByteString WireChunk
forall a b. (a -> b) -> a -> b
$ do
    (Int
consumed0, (OpTerm
term, ClosedOp
op)) <- Parser (OpTerm, ClosedOp) -> Parser (Int, (OpTerm, ClosedOp))
forall a. Parser a -> Parser (Int, a)
withInputSize Parser (OpTerm, ClosedOp)
parseDescAndClosedOp
    let parseReducedChunk :: ClosedOp -> Bool -> Parser ByteString WireChunk
parseReducedChunk ClosedOp
wrcHeader Bool
isQuery = do
            [Op]
wrcBody <- Int -> Parser [Op]
parseReducedOps (Int -> Parser [Op]) -> Int -> Parser [Op]
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
consumed0
            WireChunk -> Parser ByteString WireChunk
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WireChunk -> Parser ByteString WireChunk)
-> WireChunk -> Parser ByteString WireChunk
forall a b. (a -> b) -> a -> b
$ (if Bool
isQuery then WireReducedChunk -> WireChunk
Query else WireReducedChunk -> WireChunk
Value) WireReducedChunk :: ClosedOp -> [Op] -> WireReducedChunk
WireReducedChunk{[Op]
ClosedOp
$sel:wrcBody:WireReducedChunk :: [Op]
$sel:wrcHeader:WireReducedChunk :: ClosedOp
wrcBody :: [Op]
wrcHeader :: ClosedOp
..}
    case OpTerm
term of
        OpTerm
THeader  -> ClosedOp -> Bool -> Parser ByteString WireChunk
parseReducedChunk ClosedOp
op Bool
False
        OpTerm
TQuery   -> ClosedOp -> Bool -> Parser ByteString WireChunk
parseReducedChunk ClosedOp
op Bool
True
        OpTerm
TReduced -> String -> Parser ByteString WireChunk
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"reduced op without a chunk"
        OpTerm
TClosed  -> Size -> Int -> Parser ByteString ()
forall (f :: * -> *). MonadFail f => Size -> Int -> f ()
assertSize Size
size Int
consumed0 Parser ByteString () -> WireChunk -> Parser ByteString WireChunk
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ClosedOp -> WireChunk
Closed ClosedOp
op

-- | Assert that is such as expected
assertSize :: MonadFail f => Size -> Int -> f ()
assertSize :: Size -> Int -> f ()
assertSize Size
expected Int
consumed =
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
consumed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
expected) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
    String -> f ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$
    String
"size mismatch: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a s. (Show a, IsString s) => a -> s
show Size
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a s. (Show a, IsString s) => a -> s
show Int
consumed

-- | 'Parser' for a sequence of reduced ops
parseReducedOps :: Int -> Parser [Op]
parseReducedOps :: Int -> Parser [Op]
parseReducedOps = String -> Parser [Op] -> Parser [Op]
forall a. String -> Parser a -> Parser a
label String
"[Op]" (Parser [Op] -> Parser [Op])
-> (Int -> Parser [Op]) -> Int -> Parser [Op]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser [Op]
go
  where
    go :: Int -> Parser [Op]
go = \case
        Int
0        -> [Op] -> Parser [Op]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Int
expected -> do
            (Int
consumed, (OpTerm
TReduced, Op
op)) <- Parser (OpTerm, Op) -> Parser (Int, (OpTerm, Op))
forall a. Parser a -> Parser (Int, a)
withInputSize Parser (OpTerm, Op)
parseDescAndReducedOp
            case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
consumed Int
expected of
                Ordering
LT -> (Op
op Op -> [Op] -> [Op]
forall a. a -> [a] -> [a]
:) ([Op] -> [Op]) -> Parser [Op] -> Parser [Op]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [Op]
go (Int
expected Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
consumed)
                Ordering
EQ -> [Op] -> Parser [Op]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Op
op]
                Ordering
GT -> String -> Parser [Op]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible"

-- | 'Parser' for closed op, returning the op's terminator along with the op
parseDescAndClosedOp :: Parser (OpTerm, ClosedOp)
parseDescAndClosedOp :: Parser (OpTerm, ClosedOp)
parseDescAndClosedOp = String -> Parser (OpTerm, ClosedOp) -> Parser (OpTerm, ClosedOp)
forall a. String -> Parser a -> Parser a
label String
"d+ClosedOp" (Parser (OpTerm, ClosedOp) -> Parser (OpTerm, ClosedOp))
-> Parser (OpTerm, ClosedOp) -> Parser (OpTerm, ClosedOp)
forall a b. (a -> b) -> a -> b
$ do
    (Desc
desc, Size
size) <- Parser (Desc, Size)
parseDesc
    Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Size
size Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
        String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"desc = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Desc -> String
forall a s. (Show a, IsString s) => a -> s
show Desc
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a s. (Show a, IsString s) => a -> s
show Size
size
    case Desc
desc of
        Desc
DOpClosed       -> (OpTerm
TClosed,)   (ClosedOp -> (OpTerm, ClosedOp))
-> Parser ByteString ClosedOp -> Parser (OpTerm, ClosedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ClosedOp
parseClosedOp
        Desc
DOpHeader       -> (OpTerm
THeader,)   (ClosedOp -> (OpTerm, ClosedOp))
-> Parser ByteString ClosedOp -> Parser (OpTerm, ClosedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ClosedOp
parseClosedOp
        Desc
DOpQueryHeader  -> (OpTerm
TQuery,)    (ClosedOp -> (OpTerm, ClosedOp))
-> Parser ByteString ClosedOp -> Parser (OpTerm, ClosedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ClosedOp
parseClosedOp
        Desc
_               -> String -> Parser (OpTerm, ClosedOp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (OpTerm, ClosedOp))
-> String -> Parser (OpTerm, ClosedOp)
forall a b. (a -> b) -> a -> b
$ String
"unimplemented " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Desc -> String
forall a s. (Show a, IsString s) => a -> s
show Desc
desc

-- | 'Parser' for reduced op, returning the op's terminator along with the op
parseDescAndReducedOp :: Parser (OpTerm, Op)
parseDescAndReducedOp :: Parser (OpTerm, Op)
parseDescAndReducedOp = String -> Parser (OpTerm, Op) -> Parser (OpTerm, Op)
forall a. String -> Parser a -> Parser a
label String
"d+ClosedOp" (Parser (OpTerm, Op) -> Parser (OpTerm, Op))
-> Parser (OpTerm, Op) -> Parser (OpTerm, Op)
forall a b. (a -> b) -> a -> b
$ do
    (Desc
desc, Size
size) <- Parser (Desc, Size)
parseDesc
    Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Size
size Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
        String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"desc = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Desc -> String
forall a s. (Show a, IsString s) => a -> s
show Desc
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a s. (Show a, IsString s) => a -> s
show Size
size
    case Desc
desc of
        Desc
DOpReduced      -> (OpTerm
TReduced,)  (Op -> (OpTerm, Op)) -> Parser ByteString Op -> Parser (OpTerm, Op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Op
parseOpenOp
        Desc
_               -> String -> Parser (OpTerm, Op)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (OpTerm, Op)) -> String -> Parser (OpTerm, Op)
forall a b. (a -> b) -> a -> b
$ String
"unimplemented " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Desc -> String
forall a s. (Show a, IsString s) => a -> s
show Desc
desc

-- | 'Parser' for closed op without terminator
parseClosedOp :: Parser ClosedOp
parseClosedOp :: Parser ByteString ClosedOp
parseClosedOp = String -> Parser ByteString ClosedOp -> Parser ByteString ClosedOp
forall a. String -> Parser a -> Parser a
label String
"ClosedOp" (Parser ByteString ClosedOp -> Parser ByteString ClosedOp)
-> Parser ByteString ClosedOp -> Parser ByteString ClosedOp
forall a b. (a -> b) -> a -> b
$ do
    UUID
reducerId <- Desc -> Parser UUID
parseOpKey Desc
DUuidReducer
    UUID
objectId  <- Desc -> Parser UUID
parseOpKey Desc
DUuidObject
    Op
op        <- Parser ByteString Op
parseOpenOp
    ClosedOp -> Parser ByteString ClosedOp
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosedOp :: UUID -> UUID -> Op -> ClosedOp
ClosedOp{UUID
Op
$sel:op:ClosedOp :: Op
$sel:objectId:ClosedOp :: UUID
$sel:reducerId:ClosedOp :: UUID
op :: Op
objectId :: UUID
reducerId :: UUID
..}

-- | 'Parser' for reduced op without terminator
parseOpenOp :: Parser Op
parseOpenOp :: Parser ByteString Op
parseOpenOp = String -> Parser ByteString Op -> Parser ByteString Op
forall a. String -> Parser a -> Parser a
label String
"Op" (Parser ByteString Op -> Parser ByteString Op)
-> Parser ByteString Op -> Parser ByteString Op
forall a b. (a -> b) -> a -> b
$ do
    UUID
opId    <- Desc -> Parser UUID
parseOpKey Desc
DUuidOp
    UUID
refId   <- Desc -> Parser UUID
parseOpKey Desc
DUuidRef
    Payload
payload <- Parser Payload
parsePayload
    Op -> Parser ByteString Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op :: UUID -> UUID -> Payload -> Op
Op{Payload
UUID
$sel:payload:Op :: Payload
$sel:refId:Op :: UUID
$sel:opId:Op :: UUID
payload :: Payload
refId :: UUID
opId :: UUID
..}

-- | 'Parser' for an op key (type, object, event, or reference)
parseOpKey :: Desc -> Parser UUID
parseOpKey :: Desc -> Parser UUID
parseOpKey Desc
expectedType = String -> Parser UUID -> Parser UUID
forall a. String -> Parser a -> Parser a
label String
"OpKey" (Parser UUID -> Parser UUID) -> Parser UUID -> Parser UUID
forall a b. (a -> b) -> a -> b
$ do
    (Desc
desc, Size
size) <- Parser (Desc, Size)
parseDesc
    let go :: Parser UUID
go = do
            Bool -> Parser ByteString ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ByteString ()) -> Bool -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ Desc
desc Desc -> Desc -> Bool
forall a. Eq a => a -> a -> Bool
== Desc
expectedType
            Size -> Parser UUID
uuid Size
size
    case Desc
desc of
        Desc
DUuidReducer -> Parser UUID
go
        Desc
DUuidObject  -> Parser UUID
go
        Desc
DUuidOp      -> Parser UUID
go
        Desc
DUuidRef     -> Parser UUID
go
        Desc
_            -> String -> Parser UUID
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser UUID) -> String -> Parser UUID
forall a b. (a -> b) -> a -> b
$ Desc -> String
forall a s. (Show a, IsString s) => a -> s
show Desc
desc

-- | 'Parser' for UUID
uuid
    :: Size  -- ^ expected input length
    -> Parser UUID
uuid :: Size -> Parser UUID
uuid Size
size = String -> Parser UUID -> Parser UUID
forall a. String -> Parser a -> Parser a
label String
"UUID" (Parser UUID -> Parser UUID) -> Parser UUID -> Parser UUID
forall a b. (a -> b) -> a -> b
$
    case Size
size of
        Size
16 -> do
            Word64
x <- ByteStringL -> Word64
forall a. Binary a => ByteStringL -> a
Binary.decode (ByteStringL -> Word64)
-> Parser ByteStringL -> Parser ByteString Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL Int
8
            Word64
y <- ByteStringL -> Word64
forall a. Binary a => ByteStringL -> a
Binary.decode (ByteStringL -> Word64)
-> Parser ByteStringL -> Parser ByteString Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL Int
8
            UUID -> Parser UUID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UUID -> Parser UUID) -> UUID -> Parser UUID
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
UUID Word64
x Word64
y
        Size
_  -> String -> Parser UUID
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected uuid of size 16"

-- | 'Parser' for a payload (sequence of atoms)
parsePayload :: Parser Payload
parsePayload :: Parser Payload
parsePayload = String -> Parser Payload -> Parser Payload
forall a. String -> Parser a -> Parser a
label String
"payload" (Parser Payload -> Parser Payload)
-> Parser Payload -> Parser Payload
forall a b. (a -> b) -> a -> b
$ Parser ByteString Atom -> Parser Payload
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString Atom
atom

-- | 'Parser' for an atom
atom :: Parser Atom
atom :: Parser ByteString Atom
atom = String -> Parser ByteString Atom -> Parser ByteString Atom
forall a. String -> Parser a -> Parser a
label String
"Atom" (Parser ByteString Atom -> Parser ByteString Atom)
-> Parser ByteString Atom -> Parser ByteString Atom
forall a b. (a -> b) -> a -> b
$ do
    (Desc
desc, Size
size) <- Parser (Desc, Size)
parseDesc
    case Desc
desc of
        Desc
DAtomFloat   -> Double -> Atom
AFloat   (Double -> Atom)
-> Parser ByteString Double -> Parser ByteString Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Parser ByteString Double
float   Size
size
        Desc
DAtomInteger -> Int64 -> Atom
AInteger (Int64 -> Atom)
-> Parser ByteString Int64 -> Parser ByteString Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Parser ByteString Int64
integer Size
size
        Desc
DAtomString  -> Text -> Atom
AString  (Text -> Atom) -> Parser ByteString Text -> Parser ByteString Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Parser ByteString Text
string  Size
size
        Desc
DAtomUuid    -> UUID -> Atom
AUuid    (UUID -> Atom) -> Parser UUID -> Parser ByteString Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Parser UUID
uuid    Size
size
        Desc
_            -> String -> Parser ByteString Atom
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Atom"

-- | Parse an 'Atom'
parseAtom :: ByteStringL -> Either String Atom
parseAtom :: ByteStringL -> Either String Atom
parseAtom = Parser ByteString Atom -> ByteStringL -> Either String Atom
forall a. Parser a -> ByteStringL -> Either String a
parseOnlyL (Parser ByteString Atom -> ByteStringL -> Either String Atom)
-> Parser ByteString Atom -> ByteStringL -> Either String Atom
forall a b. (a -> b) -> a -> b
$ Parser ByteString Atom
atom Parser ByteString Atom
-> Parser ByteString () -> Parser ByteString Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfInputEx

-- | 'Parser' for a float atom
float
    :: Size  -- ^ expected input length
    -> Parser Double
float :: Size -> Parser ByteString Double
float = \case
    Size
8 -> Get Double -> ByteStringL -> Double
forall a. Get a -> ByteStringL -> a
runGet Get Double
getDoublebe (ByteStringL -> Double)
-> Parser ByteStringL -> Parser ByteString Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL Int
8
    Size
_ -> Parser ByteString Double
forall a. HasCallStack => a
undefined

-- | 'Parser' for an integer atom
integer
    :: Size  -- ^ expected input length
    -> Parser Int64
integer :: Size -> Parser ByteString Int64
integer Size
size = String -> Parser ByteString Int64 -> Parser ByteString Int64
forall a. String -> Parser a -> Parser a
label String
"Integer" (Parser ByteString Int64 -> Parser ByteString Int64)
-> Parser ByteString Int64 -> Parser ByteString Int64
forall a b. (a -> b) -> a -> b
$ do
    -- big-endian, zigzag-coded, lengths 1..8
    Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Size
size Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
1 Bool -> Bool -> Bool
&& Size
size Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
8) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"integer size must be 1..8"
    Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Size
size Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
8) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"integer size /=8 not implemented"
    Word64 -> Int64
zzDecode64 (Word64 -> Int64)
-> (ByteStringL -> Word64) -> ByteStringL -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringL -> Word64
forall a. Binary a => ByteStringL -> a
Binary.decode (ByteStringL -> Int64)
-> Parser ByteStringL -> Parser ByteString Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size)

-- | 'Parser' for an string
string
    :: Size  -- ^ expected input length
    -> Parser Text
string :: Size -> Parser ByteString Text
string Size
size = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteStringL -> ByteString) -> ByteStringL -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringL -> ByteString
toStrict (ByteStringL -> Text)
-> Parser ByteStringL -> Parser ByteString Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteStringL
takeL (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size)

-- | Parse a string atom
parseString :: ByteStringL -> Either String Text
parseString :: ByteStringL -> Either String Text
parseString ByteStringL
bs =
    Parser ByteString Text -> ByteStringL -> Either String Text
forall a. Parser a -> ByteStringL -> Either String a
parseOnlyL (Size -> Parser ByteString Text
string (Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Size) -> Int64 -> Size
forall a b. (a -> b) -> a -> b
$ ByteStringL -> Int64
BSL.length ByteStringL
bs) Parser ByteString Text
-> Parser ByteString () -> Parser ByteString Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfInputEx) ByteStringL
bs