{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NumericUnderscores #-}

module Codec.Candid.Decode where

import Numeric.Natural
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as BS
import qualified Data.Map as M
import Data.List
import Data.Void
import Data.Serialize.LEB128.Lenient
import qualified Data.Serialize.Get as G
import qualified Data.Serialize.IEEE754 as G
import Control.Monad

import Codec.Candid.Data
import Codec.Candid.TypTable
import Codec.Candid.Types
import Codec.Candid.FieldName

-- | Decode binay value into the type description and the untyped value
-- representation.
decodeVals :: BS.ByteString -> Either String (SeqDesc, [Value])
decodeVals :: ByteString -> Either String (SeqDesc, [Value])
decodeVals ByteString
bytes = Get (SeqDesc, [Value])
-> ByteString -> Either String (SeqDesc, [Value])
forall a. Get a -> ByteString -> Either String a
G.runGet Get (SeqDesc, [Value])
go (ByteString -> ByteString
BS.toStrict ByteString
bytes)
  where
    go :: Get (SeqDesc, [Value])
go = do
        Get ()
decodeMagic
        SeqDesc
arg_tys <- Get SeqDesc
decodeTypTable
        [Value]
vs <- (Type Void -> Get Value) -> [Type Void] -> Get [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type Void -> Get Value
decodeVal (SeqDesc -> [Type Void]
tieKnot (SeqDesc -> SeqDesc
voidEmptyTypes SeqDesc
arg_tys))
        let n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Value -> Int
countZeroSizeVectors (Value -> Int) -> [Value] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
vs)
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2_000_000) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ do
            String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Message contains " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" zero sized values in a vector, exceeding the limit of 2_000_000"
        Get Int
G.remaining Get Int
-> (Int -> Get (SeqDesc, [Value])) -> Get (SeqDesc, [Value])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Int
0 -> (SeqDesc, [Value]) -> Get (SeqDesc, [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqDesc
arg_tys, [Value]
vs)
            Int
n -> String -> Get (SeqDesc, [Value])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (SeqDesc, [Value]))
-> String -> Get (SeqDesc, [Value])
forall a b. (a -> b) -> a -> b
$ String
"Unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" left-over bytes"

decodeVal :: Type Void -> G.Get Value
decodeVal :: Type Void -> Get Value
decodeVal Type Void
BoolT = Get Word8
G.getWord8 Get Word8 -> (Word8 -> Get Value) -> Get Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
0 -> Value -> Get Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV Bool
False
    Word8
1 -> Value -> Get Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV Bool
True
    Word8
_ -> String -> Get Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid boolean value"
decodeVal Type Void
NatT = Natural -> Value
NatV (Natural -> Value) -> Get Natural -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Natural
forall a. LEB128 a => Get a
getLEB128
decodeVal Type Void
Nat8T = Word8 -> Value
Nat8V (Word8 -> Value) -> Get Word8 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
G.getWord8
decodeVal Type Void
Nat16T = Word16 -> Value
Nat16V (Word16 -> Value) -> Get Word16 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
G.getWord16le
decodeVal Type Void
Nat32T = Word32 -> Value
Nat32V (Word32 -> Value) -> Get Word32 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
G.getWord32le
decodeVal Type Void
Nat64T = Word64 -> Value
Nat64V (Word64 -> Value) -> Get Word64 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
G.getWord64le
decodeVal Type Void
IntT = Integer -> Value
IntV (Integer -> Value) -> Get Integer -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
forall a. SLEB128 a => Get a
getSLEB128
decodeVal Type Void
Int8T = Int8 -> Value
Int8V (Int8 -> Value) -> Get Int8 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
G.getInt8
decodeVal Type Void
Int16T = Int16 -> Value
Int16V (Int16 -> Value) -> Get Int16 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
G.getInt16le
decodeVal Type Void
Int32T = Int32 -> Value
Int32V (Int32 -> Value) -> Get Int32 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
G.getInt32le
decodeVal Type Void
Int64T = Int64 -> Value
Int64V (Int64 -> Value) -> Get Int64 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
G.getInt64le
decodeVal Type Void
Float32T = Float -> Value
Float32V (Float -> Value) -> Get Float -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Float
G.getFloat32le
decodeVal Type Void
Float64T = Double -> Value
Float64V (Double -> Value) -> Get Double -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
G.getFloat64le
decodeVal Type Void
TextT = Text -> Value
TextV (Text -> Value) -> Get Text -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
decodeText
decodeVal Type Void
NullT = Value -> Get Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
NullV
decodeVal Type Void
ReservedT = Value -> Get Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
ReservedV
decodeVal (OptT Type Void
t) = Get Word8
G.getWord8 Get Word8 -> (Word8 -> Get Value) -> Get Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
0 -> Value -> Get Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Value
OptV Maybe Value
forall a. Maybe a
Nothing
    Word8
1 -> Maybe Value -> Value
OptV (Maybe Value -> Value) -> (Value -> Maybe Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Value) -> Get Value -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Get Value
decodeVal Type Void
t
    Word8
_ -> String -> Get Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid optional value"
decodeVal Type Void
BlobT = ByteString -> Value
BlobV (ByteString -> Value) -> Get ByteString -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
decodeBytes
decodeVal (VecT Type Void
t) = do
    Int
n <- Get Int
forall a. Integral a => Get a
getLEB128Int
    case Type Void -> Maybe Value
forall a. Type a -> Maybe Value
decodeZeroBytes Type Void
t of
        Just Value
v ->Value -> Get Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Int -> Value -> Value
RepeatV Int
n Value
v
        Maybe Value
Nothing -> Vector Value -> Value
VecV (Vector Value -> Value)
-> ([Value] -> Vector Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> Get [Value] -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Value -> Get [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Type Void -> Get Value
decodeVal Type Void
t)
decodeVal (RecT Fields Void
fs)
    | Bool
isTuple   = [Value] -> Value
TupV ([Value] -> Value) -> Get [Value] -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldName, Type Void) -> Get Value) -> Fields Void -> Get [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FieldName
_,Type Void
t) -> Type Void -> Get Value
decodeVal Type Void
t) Fields Void
fs'
    | Bool
otherwise = [(FieldName, Value)] -> Value
RecV ([(FieldName, Value)] -> Value)
-> Get [(FieldName, Value)] -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldName, Type Void) -> Get (FieldName, Value))
-> Fields Void -> Get [(FieldName, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FieldName
fn, Type Void
t) -> (FieldName
fn,) (Value -> (FieldName, Value))
-> Get Value -> Get (FieldName, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Get Value
decodeVal Type Void
t) Fields Void
fs'
  where
    fs' :: Fields Void
fs' = ((FieldName, Type Void) -> FieldName) -> Fields Void -> Fields Void
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Type Void) -> FieldName
forall a b. (a, b) -> a
fst Fields Void
fs
    isTuple :: Bool
isTuple = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (FieldName -> FieldName -> Bool)
-> [FieldName] -> [FieldName] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (((FieldName, Type Void) -> FieldName) -> Fields Void -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, Type Void) -> FieldName
forall a b. (a, b) -> a
fst Fields Void
fs') ((Word32 -> FieldName) -> [Word32] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> FieldName
hashedField [Word32
0..])
decodeVal (VariantT Fields Void
fs) = do
    Int
i <- Get Int
forall a. Integral a => Get a
getLEB128Int
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Fields Void -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Fields Void
fs) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"variant index out of bound"
    let (FieldName
fn, Type Void
t) = Fields Void
fs' Fields Void -> Int -> (FieldName, Type Void)
forall a. [a] -> Int -> a
!! Int
i
    FieldName -> Value -> Value
VariantV FieldName
fn (Value -> Value) -> Get Value -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Get Value
decodeVal Type Void
t
  where
    fs' :: Fields Void
fs' = ((FieldName, Type Void) -> FieldName) -> Fields Void -> Fields Void
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Type Void) -> FieldName
forall a b. (a, b) -> a
fst Fields Void
fs
decodeVal (FuncT MethodType Void
_) = do
    Get ()
referenceByte
    Get ()
referenceByte
    Principal -> Text -> Value
FuncV (Principal -> Text -> Value)
-> Get Principal -> Get (Text -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Principal
decodePrincipal Get (Text -> Value) -> Get Text -> Get Value
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Text
decodeText
decodeVal (ServiceT [(Text, MethodType Void)]
_) = do
    Get ()
referenceByte
    Principal -> Value
ServiceV (Principal -> Value) -> Get Principal -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Principal
decodePrincipal
decodeVal Type Void
PrincipalT = do
    Get ()
referenceByte
    Principal -> Value
PrincipalV (Principal -> Value) -> Get Principal -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Principal
decodePrincipal

decodeVal Type Void
EmptyT = String -> Get Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty value"
decodeVal Type Void
FutureT = do
    Int64
m <- Get Int64
forall a. Integral a => Get a
getLEB128Int
    Natural
_n <- Integral Natural => Get Natural
forall a. Integral a => Get a
getLEB128Int @Natural
    ByteString
_ <- Int64 -> Get ByteString
G.getLazyByteString Int64
m
    Value -> Get Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
FutureV

decodeVal (RefT Void
v) = Void -> Get Value
forall a. Void -> a
absurd Void
v

referenceByte :: G.Get ()
referenceByte :: Get ()
referenceByte = Get Word8
G.getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
0 -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"reference encountered"
    Word8
1 -> () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Word8
_ -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid reference tag"

decodeBytes :: G.Get BS.ByteString
decodeBytes :: Get ByteString
decodeBytes = Get Int64
forall a. Integral a => Get a
getLEB128Int Get Int64 -> (Int64 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int64 -> Get ByteString
G.getLazyByteString

decodeText :: G.Get T.Text
decodeText :: Get Text
decodeText = do
    ByteString
bs <- Get ByteString
decodeBytes
    case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> ByteString
BS.toStrict ByteString
bs) of
        Left UnicodeException
err -> String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text) -> String -> Get Text
forall a b. (a -> b) -> a -> b
$ String
"Invalid utf8: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err
        Right Text
t -> Text -> Get Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

decodePrincipal :: G.Get Principal
decodePrincipal :: Get Principal
decodePrincipal = ByteString -> Principal
Principal (ByteString -> Principal) -> Get ByteString -> Get Principal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
decodeBytes

decodeMagic :: G.Get ()
decodeMagic :: Get ()
decodeMagic = do
    ByteString
magic <- Int -> Get ByteString
G.getBytes Int
4
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack String
"DIDL")) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Expected magic bytes \"DIDL\", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
magic

getLEB128Int :: Integral a => G.Get a
getLEB128Int :: Get a
getLEB128Int = Natural -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> a) -> Get Natural -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LEB128 Natural => Get Natural
forall a. LEB128 a => Get a
getLEB128 @Natural

-- eagerly detect overshoot
checkOvershoot :: Natural -> G.Get ()
checkOvershoot :: Natural -> Get ()
checkOvershoot Natural
n = Get ByteString -> Get ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Get ByteString -> Get ByteString
forall a. Get a -> Get a
G.lookAhead (Get ByteString -> Get ByteString)
-> Get ByteString -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
G.ensure (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n)

decodeSeq :: G.Get a -> G.Get [a]
decodeSeq :: Get a -> Get [a]
decodeSeq Get a
act = do
    Int
len <- Get Int
forall a. Integral a => Get a
getLEB128Int
    Natural -> Get ()
checkOvershoot (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    Int -> Get a -> Get [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Get a
act

decodeFoldSeq :: (a -> G.Get a) -> (a -> G.Get a)
decodeFoldSeq :: (a -> Get a) -> a -> Get a
decodeFoldSeq a -> Get a
act a
x = do
    Integer
len <- Integral Integer => Get Integer
forall a. Integral a => Get a
getLEB128Int @Integer
    Natural -> Get ()
checkOvershoot (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
len)
    Integer -> a -> Get a
forall t. (Eq t, Num t) => t -> a -> Get a
go Integer
len a
x
  where
    go :: t -> a -> Get a
go t
0 a
x = a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    go t
n a
x = a -> Get a
act a
x Get a -> (a -> Get a) -> Get a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> a -> Get a
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)

decodeTypTable :: G.Get SeqDesc
decodeTypTable :: Get SeqDesc
decodeTypTable = do
    Natural
len <- Get Natural
forall a. LEB128 a => Get a
getLEB128
    Natural -> Get ()
checkOvershoot Natural
len
    [Either (Type Int) PreService]
table <- Int
-> Get (Either (Type Int) PreService)
-> Get [Either (Type Int) PreService]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
len) (Natural -> Get (Either (Type Int) PreService)
decodeTypTableEntry Natural
len)
    [Type Int]
table <- [Either (Type Int) PreService] -> Get [Type Int]
resolveServiceT [Either (Type Int) PreService]
table
    let m :: Map Int (Type Int)
m = [(Int, Type Int)] -> Map Int (Type Int)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [Type Int] -> [(Int, Type Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Type Int]
table)
    [Type Int]
ts <- Get (Type Int) -> Get [Type Int]
forall a. Get a -> Get [a]
decodeSeq (Natural -> Get (Type Int)
decodeTypRef Natural
len)
    SeqDesc -> Get SeqDesc
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqDesc -> Get SeqDesc) -> SeqDesc -> Get SeqDesc
forall a b. (a -> b) -> a -> b
$ Map Int (Type Int) -> [Type Int] -> SeqDesc
forall k.
(Pretty k, Ord k) =>
Map k (Type k) -> [Type k] -> SeqDesc
SeqDesc Map Int (Type Int)
m [Type Int]
ts

type PreService = [(T.Text, Int)]

decodeTypTableEntry :: Natural -> G.Get (Either (Type Int) PreService)
decodeTypTableEntry :: Natural -> Get (Either (Type Int) PreService)
decodeTypTableEntry Natural
max = SLEB128 Integer => Get Integer
forall a. SLEB128 a => Get a
getSLEB128 @Integer Get Integer
-> (Integer -> Get (Either (Type Int) PreService))
-> Get (Either (Type Int) PreService)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -18 -> Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left (Type Int -> Either (Type Int) PreService)
-> (Type Int -> Type Int)
-> Type Int
-> Either (Type Int) PreService
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type Int -> Type Int
forall a. Type a -> Type a
OptT (Type Int -> Either (Type Int) PreService)
-> Get (Type Int) -> Get (Either (Type Int) PreService)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Get (Type Int)
decodeTypRef Natural
max
    -19 -> do
        Type Int
t <- Natural -> Get (Type Int)
decodeTypRef Natural
max
        Either (Type Int) PreService -> Get (Either (Type Int) PreService)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Type Int) PreService
 -> Get (Either (Type Int) PreService))
-> Either (Type Int) PreService
-> Get (Either (Type Int) PreService)
forall a b. (a -> b) -> a -> b
$ if Type Int
t Type Int -> Type Int -> Bool
forall a. Eq a => a -> a -> Bool
== Type Int
forall a. Type a
Nat8T then Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left Type Int
forall a. Type a
BlobT
                             else Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left (Type Int -> Type Int
forall a. Type a -> Type a
VecT Type Int
t)
    -20 -> Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left (Type Int -> Either (Type Int) PreService)
-> (Fields Int -> Type Int)
-> Fields Int
-> Either (Type Int) PreService
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fields Int -> Type Int
forall a. Fields a -> Type a
RecT (Fields Int -> Either (Type Int) PreService)
-> Get (Fields Int) -> Get (Either (Type Int) PreService)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Get (Fields Int)
decodeTypFields Natural
max
    -21 -> Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left (Type Int -> Either (Type Int) PreService)
-> (Fields Int -> Type Int)
-> Fields Int
-> Either (Type Int) PreService
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fields Int -> Type Int
forall a. Fields a -> Type a
VariantT (Fields Int -> Either (Type Int) PreService)
-> Get (Fields Int) -> Get (Either (Type Int) PreService)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Get (Fields Int)
decodeTypFields Natural
max
    -22 -> do
        [Type Int]
a <- Get (Type Int) -> Get [Type Int]
forall a. Get a -> Get [a]
decodeSeq (Natural -> Get (Type Int)
decodeTypRef Natural
max)
        [Type Int]
r <- Get (Type Int) -> Get [Type Int]
forall a. Get a -> Get [a]
decodeSeq (Natural -> Get (Type Int)
decodeTypRef Natural
max)
        MethodType Int
m <- (MethodType Int -> Get (MethodType Int))
-> MethodType Int -> Get (MethodType Int)
forall a. (a -> Get a) -> a -> Get a
decodeFoldSeq MethodType Int -> Get (MethodType Int)
forall t. MethodType t -> Get (MethodType t)
decodeFuncAnn ([Type Int] -> [Type Int] -> Bool -> Bool -> Bool -> MethodType Int
forall a.
[Type a] -> [Type a] -> Bool -> Bool -> Bool -> MethodType a
MethodType [Type Int]
a [Type Int]
r Bool
False Bool
False Bool
False)
        Either (Type Int) PreService -> Get (Either (Type Int) PreService)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Type Int) PreService
 -> Get (Either (Type Int) PreService))
-> Either (Type Int) PreService
-> Get (Either (Type Int) PreService)
forall a b. (a -> b) -> a -> b
$ Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left (MethodType Int -> Type Int
forall a. MethodType a -> Type a
FuncT MethodType Int
m)
    -23 -> do
        PreService
m <- Get (Text, Int) -> Get PreService
forall a. Get a -> Get [a]
decodeSeq ((,) (Text -> Int -> (Text, Int))
-> Get Text -> Get (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
decodeText Get (Int -> (Text, Int)) -> Get Int -> Get (Text, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> Get Int
decodeFuncTypRef Natural
max)
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. Ord a => [a] -> Bool
isOrdered (((Text, Int) -> Text) -> PreService -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Text
forall a b. (a, b) -> a
fst PreService
m)) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
            String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Service methods not in strict order"
        Either (Type Int) PreService -> Get (Either (Type Int) PreService)
forall (m :: * -> *) a. Monad m => a -> m a
return (PreService -> Either (Type Int) PreService
forall a b. b -> Either a b
Right PreService
m)
    Integer
_ -> do
        ByteString
_ <- Get Int64
forall a. Integral a => Get a
getLEB128Int Get Int64 -> (Int64 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int64 -> Get ByteString
G.getLazyByteString
        Either (Type Int) PreService -> Get (Either (Type Int) PreService)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type Int -> Either (Type Int) PreService
forall a b. a -> Either a b
Left Type Int
forall a. Type a
FutureT)

decodeTypRef :: Natural -> G.Get (Type Int)
decodeTypRef :: Natural -> Get (Type Int)
decodeTypRef Natural
max = do
    Integer
i <- Get Integer
forall a. SLEB128 a => Get a
getSLEB128
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
max) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Type reference out of range"
    if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
    then case Integer -> Maybe (Type Int)
forall a. Integer -> Maybe (Type a)
primTyp Integer
i of
        Just Type Int
t -> Type Int -> Get (Type Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Type Int
t
        Maybe (Type Int)
Nothing -> String -> Get (Type Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail  (String -> Get (Type Int)) -> String -> Get (Type Int)
forall a b. (a -> b) -> a -> b
$ String
"Unknown prim typ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i
    else Type Int -> Get (Type Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type Int -> Get (Type Int)) -> Type Int -> Get (Type Int)
forall a b. (a -> b) -> a -> b
$ Int -> Type Int
forall a. a -> Type a
RefT (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)

decodeFuncTypRef :: Natural -> G.Get Int
decodeFuncTypRef :: Natural -> Get Int
decodeFuncTypRef Natural
max = do
    Integer
i <- Get Integer
forall a. SLEB128 a => Get a
getSLEB128
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
max) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Type reference out of range"
    if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
    then case Integer -> Maybe (Type Any)
forall a. Integer -> Maybe (Type a)
primTyp Integer
i of
        Just Type Any
_ -> String -> Get Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Primitive type as method type in service type"
        Maybe (Type Any)
Nothing -> String -> Get Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail  (String -> Get Int) -> String -> Get Int
forall a b. (a -> b) -> a -> b
$ String
"Unknown prim typ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i
    else Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Get Int) -> Int -> Get Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i

-- This resolves PreServiceT to ServiceT
resolveServiceT :: [Either (Type Int) PreService] -> G.Get [Type Int]
resolveServiceT :: [Either (Type Int) PreService] -> Get [Type Int]
resolveServiceT [Either (Type Int) PreService]
table = (Either (Type Int) PreService -> Get (Type Int))
-> [Either (Type Int) PreService] -> Get [Type Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Either (Type Int) PreService -> Get (Type Int)
forall (f :: * -> *).
MonadFail f =>
Either (Type Int) PreService -> f (Type Int)
go [Either (Type Int) PreService]
table
  where
    m :: Map Int (Either (Type Int) PreService)
m = [(Int, Either (Type Int) PreService)]
-> Map Int (Either (Type Int) PreService)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int]
-> [Either (Type Int) PreService]
-> [(Int, Either (Type Int) PreService)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Either (Type Int) PreService]
table)

    go :: Either (Type Int) PreService -> f (Type Int)
go (Left Type Int
t) = Type Int -> f (Type Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type Int
t
    go (Right PreService
is) = [(Text, MethodType Int)] -> Type Int
forall a. [(Text, MethodType a)] -> Type a
ServiceT ([(Text, MethodType Int)] -> Type Int)
-> f [(Text, MethodType Int)] -> f (Type Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Int) -> f (Text, MethodType Int))
-> PreService -> f [(Text, MethodType Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, Int) -> f (Text, MethodType Int)
forall (m :: * -> *) a.
MonadFail m =>
(a, Int) -> m (a, MethodType Int)
goMethod PreService
is

    goMethod :: (a, Int) -> m (a, MethodType Int)
goMethod (a
n, Int
i) = case Map Int (Either (Type Int) PreService)
m Map Int (Either (Type Int) PreService)
-> Int -> Either (Type Int) PreService
forall k a. Ord k => Map k a -> k -> a
M.! Int
i of
        Left (FuncT MethodType Int
t) -> (a, MethodType Int) -> m (a, MethodType Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,MethodType Int
t)
        Either (Type Int) PreService
_ -> String -> m (a, MethodType Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Method type not a function type"


decodeFuncAnn :: MethodType t -> G.Get (MethodType t)
decodeFuncAnn :: MethodType t -> Get (MethodType t)
decodeFuncAnn MethodType t
m = Get Word8
G.getWord8 Get Word8 -> (Word8 -> Get (MethodType t)) -> Get (MethodType t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
1 -> do
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MethodType t -> Bool
forall a. MethodType a -> Bool
methQuery MethodType t
m) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"query annotation duplicated"
        MethodType t -> Get (MethodType t)
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodType t
m { methQuery :: Bool
methQuery = Bool
True })
    Word8
2 -> do
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MethodType t -> Bool
forall a. MethodType a -> Bool
methOneway MethodType t
m) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"oneway annotation duplicated"
        MethodType t -> Get (MethodType t)
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodType t
m { methOneway :: Bool
methOneway = Bool
True })
    Word8
3 -> do
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MethodType t -> Bool
forall a. MethodType a -> Bool
methCompQuery MethodType t
m) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"composite_query annotation duplicated"
        MethodType t -> Get (MethodType t)
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodType t
m { methCompQuery :: Bool
methCompQuery = Bool
True })
    Word8
_ -> String -> Get (MethodType t)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid function annotation"


isOrdered :: Ord a => [a] -> Bool
isOrdered :: [a] -> Bool
isOrdered [] = Bool
True
isOrdered [a
_] = Bool
True
isOrdered (a
x:a
y:[a]
xs) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Ord a => [a] -> Bool
isOrdered (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

decodeTypFields :: Natural -> G.Get (Fields Int)
decodeTypFields :: Natural -> Get (Fields Int)
decodeTypFields Natural
max = do
    Fields Int
fs <- Get (FieldName, Type Int) -> Get (Fields Int)
forall a. Get a -> Get [a]
decodeSeq (Natural -> Get (FieldName, Type Int)
decodeTypField Natural
max)
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FieldName] -> Bool
forall a. Ord a => [a] -> Bool
isOrdered (((FieldName, Type Int) -> FieldName) -> Fields Int -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, Type Int) -> FieldName
forall a b. (a, b) -> a
fst Fields Int
fs)) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Fields not in strict order"
    Fields Int -> Get (Fields Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Fields Int
fs

decodeTypField :: Natural -> G.Get (FieldName, Type Int)
decodeTypField :: Natural -> Get (FieldName, Type Int)
decodeTypField Natural
max = do
    Word32
h <- Get Word32
forall a. LEB128 a => Get a
getLEB128
    Type Int
t <- Natural -> Get (Type Int)
decodeTypRef Natural
max
    (FieldName, Type Int) -> Get (FieldName, Type Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> FieldName
hashedField Word32
h, Type Int
t)

decodeZeroBytes :: Type a -> Maybe Value
decodeZeroBytes :: Type a -> Maybe Value
decodeZeroBytes Type a
ReservedT = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
ReservedV
decodeZeroBytes Type a
NullT = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
NullV
decodeZeroBytes (RecT Fields a
fs) = [(FieldName, Value)] -> Value
RecV ([(FieldName, Value)] -> Value)
-> Maybe [(FieldName, Value)] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldName, Type a) -> Maybe (FieldName, Value))
-> Fields a -> Maybe [(FieldName, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FieldName
fn, Type a
t) -> (FieldName
fn,) (Value -> (FieldName, Value))
-> Maybe Value -> Maybe (FieldName, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type a -> Maybe Value
forall a. Type a -> Maybe Value
decodeZeroBytes Type a
t) Fields a
fs'
  where
    fs' :: Fields a
fs' = ((FieldName, Type a) -> FieldName) -> Fields a -> Fields a
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Type a) -> FieldName
forall a b. (a, b) -> a
fst Fields a
fs
decodeZeroBytes Type a
_ = Maybe Value
forall a. Maybe a
Nothing

{-
isZeroSizedValue :: Value -> Bool
isZeroSizedValue ReservedV = True
isZeroSizedValue NullV = True
isZeroSizedValue (RecV fs) = all (isZeroSizedValue . snd) fs
isZeroSizedValue (TupV vs) = all isZeroSizedValue vs
isZeroSizedValue _ = False
-}

countZeroSizeVectors :: Value -> Int
countZeroSizeVectors :: Value -> Int
countZeroSizeVectors (RepeatV Int
n Value
_) = Int
n
countZeroSizeVectors (VecV Vector Value
vs) = Vector Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Value -> Int
countZeroSizeVectors (Value -> Int) -> Vector Value -> Vector Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
vs)
countZeroSizeVectors (RecV [(FieldName, Value)]
fs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Value -> Int
countZeroSizeVectors (Value -> Int)
-> ((FieldName, Value) -> Value) -> (FieldName, Value) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, Value) -> Value
forall a b. (a, b) -> b
snd ((FieldName, Value) -> Int) -> [(FieldName, Value)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldName, Value)]
fs)
countZeroSizeVectors (TupV [Value]
vs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Value -> Int
countZeroSizeVectors (Value -> Int) -> [Value] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
vs)
countZeroSizeVectors (VariantV FieldName
_ Value
v) = Value -> Int
countZeroSizeVectors Value
v
countZeroSizeVectors (OptV (Just Value
v)) = Value -> Int
countZeroSizeVectors Value
v
countZeroSizeVectors (AnnV Value
v Type Void
_) = Value -> Int
countZeroSizeVectors Value
v
countZeroSizeVectors Value
_ = Int
0