{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Wire.API.MLS.Serialisation
( ParseMLS (..),
SerialiseMLS (..),
VarInt (..),
parseMLSStream,
parseMLSVector,
serialiseMLSVector,
parseMLSBytes,
serialiseMLSBytes,
serialiseMLSBytesLazy,
parseMLSOptional,
serialiseMLSOptional,
parseMLSEnum,
serialiseMLSEnum,
MLSEnumError (..),
fromMLSEnum,
toMLSEnum',
toMLSEnum,
encodeMLS,
encodeMLS',
decodeMLS,
decodeMLS',
decodeMLSWith,
decodeMLSWith',
RawMLS (..),
rawMLSSchema,
mlsSwagger,
parseRawMLS,
mkRawMLS,
traceMLS,
)
where
import Control.Applicative
import Control.Comonad
import Control.Lens ((?~))
import Data.Aeson (FromJSON (..))
import Data.Aeson qualified as Aeson
import Data.Bifunctor
import Data.Binary
import Data.Binary.Builder (toLazyByteString)
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Json.Util
import Data.Kind
import Data.OpenApi qualified as S
import Data.Proxy
import Data.Schema
import Data.Text qualified as Text
import Debug.Trace
import Imports
import Test.QuickCheck (Arbitrary (..), chooseInt)
class ParseMLS a where
parseMLS :: Get a
class SerialiseMLS a where
serialiseMLS :: a -> Put
newtype VarInt = VarInt {VarInt -> Word32
unVarInt :: Word32}
deriving newtype (VarInt -> VarInt -> Bool
(VarInt -> VarInt -> Bool)
-> (VarInt -> VarInt -> Bool) -> Eq VarInt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VarInt -> VarInt -> Bool
== :: VarInt -> VarInt -> Bool
$c/= :: VarInt -> VarInt -> Bool
/= :: VarInt -> VarInt -> Bool
Eq, Eq VarInt
Eq VarInt =>
(VarInt -> VarInt -> Ordering)
-> (VarInt -> VarInt -> Bool)
-> (VarInt -> VarInt -> Bool)
-> (VarInt -> VarInt -> Bool)
-> (VarInt -> VarInt -> Bool)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> Ord VarInt
VarInt -> VarInt -> Bool
VarInt -> VarInt -> Ordering
VarInt -> VarInt -> VarInt
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VarInt -> VarInt -> Ordering
compare :: VarInt -> VarInt -> Ordering
$c< :: VarInt -> VarInt -> Bool
< :: VarInt -> VarInt -> Bool
$c<= :: VarInt -> VarInt -> Bool
<= :: VarInt -> VarInt -> Bool
$c> :: VarInt -> VarInt -> Bool
> :: VarInt -> VarInt -> Bool
$c>= :: VarInt -> VarInt -> Bool
>= :: VarInt -> VarInt -> Bool
$cmax :: VarInt -> VarInt -> VarInt
max :: VarInt -> VarInt -> VarInt
$cmin :: VarInt -> VarInt -> VarInt
min :: VarInt -> VarInt -> VarInt
Ord, Integer -> VarInt
VarInt -> VarInt
VarInt -> VarInt -> VarInt
(VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt)
-> (VarInt -> VarInt)
-> (VarInt -> VarInt)
-> (Integer -> VarInt)
-> Num VarInt
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: VarInt -> VarInt -> VarInt
+ :: VarInt -> VarInt -> VarInt
$c- :: VarInt -> VarInt -> VarInt
- :: VarInt -> VarInt -> VarInt
$c* :: VarInt -> VarInt -> VarInt
* :: VarInt -> VarInt -> VarInt
$cnegate :: VarInt -> VarInt
negate :: VarInt -> VarInt
$cabs :: VarInt -> VarInt
abs :: VarInt -> VarInt
$csignum :: VarInt -> VarInt
signum :: VarInt -> VarInt
$cfromInteger :: Integer -> VarInt
fromInteger :: Integer -> VarInt
Num, Int -> VarInt
VarInt -> Int
VarInt -> [VarInt]
VarInt -> VarInt
VarInt -> VarInt -> [VarInt]
VarInt -> VarInt -> VarInt -> [VarInt]
(VarInt -> VarInt)
-> (VarInt -> VarInt)
-> (Int -> VarInt)
-> (VarInt -> Int)
-> (VarInt -> [VarInt])
-> (VarInt -> VarInt -> [VarInt])
-> (VarInt -> VarInt -> [VarInt])
-> (VarInt -> VarInt -> VarInt -> [VarInt])
-> Enum VarInt
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: VarInt -> VarInt
succ :: VarInt -> VarInt
$cpred :: VarInt -> VarInt
pred :: VarInt -> VarInt
$ctoEnum :: Int -> VarInt
toEnum :: Int -> VarInt
$cfromEnum :: VarInt -> Int
fromEnum :: VarInt -> Int
$cenumFrom :: VarInt -> [VarInt]
enumFrom :: VarInt -> [VarInt]
$cenumFromThen :: VarInt -> VarInt -> [VarInt]
enumFromThen :: VarInt -> VarInt -> [VarInt]
$cenumFromTo :: VarInt -> VarInt -> [VarInt]
enumFromTo :: VarInt -> VarInt -> [VarInt]
$cenumFromThenTo :: VarInt -> VarInt -> VarInt -> [VarInt]
enumFromThenTo :: VarInt -> VarInt -> VarInt -> [VarInt]
Enum, Enum VarInt
Real VarInt
(Real VarInt, Enum VarInt) =>
(VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> VarInt)
-> (VarInt -> VarInt -> (VarInt, VarInt))
-> (VarInt -> VarInt -> (VarInt, VarInt))
-> (VarInt -> Integer)
-> Integral VarInt
VarInt -> Integer
VarInt -> VarInt -> (VarInt, VarInt)
VarInt -> VarInt -> VarInt
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: VarInt -> VarInt -> VarInt
quot :: VarInt -> VarInt -> VarInt
$crem :: VarInt -> VarInt -> VarInt
rem :: VarInt -> VarInt -> VarInt
$cdiv :: VarInt -> VarInt -> VarInt
div :: VarInt -> VarInt -> VarInt
$cmod :: VarInt -> VarInt -> VarInt
mod :: VarInt -> VarInt -> VarInt
$cquotRem :: VarInt -> VarInt -> (VarInt, VarInt)
quotRem :: VarInt -> VarInt -> (VarInt, VarInt)
$cdivMod :: VarInt -> VarInt -> (VarInt, VarInt)
divMod :: VarInt -> VarInt -> (VarInt, VarInt)
$ctoInteger :: VarInt -> Integer
toInteger :: VarInt -> Integer
Integral, Num VarInt
Ord VarInt
(Num VarInt, Ord VarInt) => (VarInt -> Rational) -> Real VarInt
VarInt -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: VarInt -> Rational
toRational :: VarInt -> Rational
Real, Int -> VarInt -> ShowS
[VarInt] -> ShowS
VarInt -> String
(Int -> VarInt -> ShowS)
-> (VarInt -> String) -> ([VarInt] -> ShowS) -> Show VarInt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VarInt -> ShowS
showsPrec :: Int -> VarInt -> ShowS
$cshow :: VarInt -> String
show :: VarInt -> String
$cshowList :: [VarInt] -> ShowS
showList :: [VarInt] -> ShowS
Show)
instance Arbitrary VarInt where
arbitrary :: Gen VarInt
arbitrary = Int -> VarInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> VarInt) -> Gen Int -> Gen VarInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
1073741823)
instance Binary VarInt where
put :: VarInt -> Put
put :: VarInt -> Put
put (VarInt Word32
w)
| Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
64 = Word8 -> Put
putWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
| Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16384 = Word16 -> Put
putWord16be (Word16
0x4000 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
| Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
1073741824 = Word32 -> Put
putWord32be (Word32
0x80000000 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
w)
| Bool
otherwise = String -> Put
forall a. HasCallStack => String -> a
error String
"invalid VarInt"
get :: Get VarInt
get :: Get VarInt
get = do
Word8
w <- Get Word8 -> Get Word8
forall a. Get a -> Get a
lookAhead Get Word8
getWord8
case Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftR (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xc0) Int
6 of
Word8
0b00 -> Word32 -> VarInt
VarInt (Word32 -> VarInt) -> (Word8 -> Word32) -> Word8 -> VarInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> VarInt) -> Get Word8 -> Get VarInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
Word8
0b01 -> Word32 -> VarInt
VarInt (Word32 -> VarInt) -> (Word16 -> Word32) -> Word16 -> VarInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x3fff) (Word32 -> Word32) -> (Word16 -> Word32) -> Word16 -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> VarInt) -> Get Word16 -> Get VarInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
Word8
0b10 -> Word32 -> VarInt
VarInt (Word32 -> VarInt) -> (Word32 -> Word32) -> Word32 -> VarInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x3fffffff) (Word32 -> Word32) -> (Word32 -> Word32) -> Word32 -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> VarInt) -> Get Word32 -> Get VarInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
Word8
_ -> String -> Get VarInt
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid VarInt prefix"
instance SerialiseMLS VarInt where serialiseMLS :: VarInt -> Put
serialiseMLS = VarInt -> Put
forall t. Binary t => t -> Put
put
instance ParseMLS VarInt where parseMLS :: Get VarInt
parseMLS = Get VarInt
forall t. Binary t => Get t
get
parseMLSStream :: Get a -> Get [a]
parseMLSStream :: forall a. Get a -> Get [a]
parseMLSStream Get a
p = do
Bool
e <- Get Bool
isEmpty
if Bool
e
then [a] -> Get [a]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else (:) (a -> [a] -> [a]) -> Get a -> Get ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
p Get ([a] -> [a]) -> Get [a] -> Get [a]
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get a -> Get [a]
forall a. Get a -> Get [a]
parseMLSStream Get a
p
parseMLSVector :: forall w a. (Binary w, Integral w) => Get a -> Get [a]
parseMLSVector :: forall w a. (Binary w, Integral w) => Get a -> Get [a]
parseMLSVector Get a
getItem = do
w
len <- forall t. Binary t => Get t
get @w
if w
len w -> w -> Bool
forall a. Eq a => a -> a -> Bool
== w
0
then [a] -> Get [a]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else Int -> Get [a] -> Get [a]
forall a. Int -> Get a -> Get a
isolate (w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral w
len) (Get [a] -> Get [a]) -> Get [a] -> Get [a]
forall a b. (a -> b) -> a -> b
$ Int64 -> Get [a]
go (w -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral w
len)
where
go :: Int64 -> Get [a]
go :: Int64 -> Get [a]
go Int64
endPos = do
a
x <- Get a
getItem
Int64
pos <- Get Int64
bytesRead
(:) a
x ([a] -> [a]) -> Get [a] -> Get [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if Int64
pos Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
endPos then Int64 -> Get [a]
go Int64
endPos else [a] -> Get [a]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
serialiseMLSVector ::
forall w a.
(Binary w, Integral w) =>
(a -> Put) ->
[a] ->
Put
serialiseMLSVector :: forall w a. (Binary w, Integral w) => (a -> Put) -> [a] -> Put
serialiseMLSVector a -> Put
p =
forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytesLazy @w (ByteString -> Put) -> ([a] -> ByteString) -> [a] -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> ([a] -> Builder) -> [a] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> Builder
forall a. PutM a -> Builder
execPut (Put -> Builder) -> ([a] -> Put) -> [a] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Put) -> [a] -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> Put
p
parseMLSBytes :: forall w. (Binary w, Integral w) => Get ByteString
parseMLSBytes :: forall w. (Binary w, Integral w) => Get ByteString
parseMLSBytes = do
Int
len <- w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w -> Int) -> Get w -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get @w
Int -> Get ByteString
getByteString Int
len
serialiseMLSBytes :: forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytes :: forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytes ByteString
x = do
forall t. Binary t => t -> Put
put @w (Int -> w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
x))
ByteString -> Put
putByteString ByteString
x
serialiseMLSBytesLazy :: forall w. (Binary w, Integral w) => LBS.ByteString -> Put
serialiseMLSBytesLazy :: forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytesLazy ByteString
x = do
forall t. Binary t => t -> Put
put @w (Int64 -> w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
LBS.length ByteString
x))
ByteString -> Put
putLazyByteString ByteString
x
parseMLSOptional :: Get a -> Get (Maybe a)
parseMLSOptional :: forall a. Get a -> Get (Maybe a)
parseMLSOptional Get a
g = do
Word8
b <- Get Word8
getWord8
Maybe (Get a) -> Get (Maybe a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (Get a) -> Get (Maybe a)) -> Maybe (Get a) -> Get (Maybe a)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) Maybe () -> Get a -> Maybe (Get a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Get a
g
serialiseMLSOptional :: (a -> Put) -> Maybe a -> Put
serialiseMLSOptional :: forall a. (a -> Put) -> Maybe a -> Put
serialiseMLSOptional a -> Put
_p Maybe a
Nothing = Word8 -> Put
putWord8 Word8
0
serialiseMLSOptional a -> Put
p (Just a
x) = do
Word8 -> Put
putWord8 Word8
1
a -> Put
p a
x
parseMLSEnum ::
forall (w :: Type) a.
(Bounded a, Enum a, Integral w, Binary w) =>
String ->
Get a
parseMLSEnum :: forall w a.
(Bounded a, Enum a, Integral w, Binary w) =>
String -> Get a
parseMLSEnum String
name = String -> w -> Get a
forall a w (f :: * -> *).
(Bounded a, Enum a, MonadFail f, Integral w) =>
String -> w -> f a
toMLSEnum String
name (w -> Get a) -> Get w -> Get a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t. Binary t => Get t
get @w
serialiseMLSEnum ::
forall w a.
(Enum a, Integral w, Binary w) =>
a ->
Put
serialiseMLSEnum :: forall w a. (Enum a, Integral w, Binary w) => a -> Put
serialiseMLSEnum = w -> Put
forall t. Binary t => t -> Put
put (w -> Put) -> (a -> w) -> a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. (Integral w, Enum a) => a -> w
fromMLSEnum @w
data MLSEnumError = MLSEnumUnknown Int | MLSEnumInvalid
toMLSEnum' :: forall a w. (Bounded a, Enum a, Integral w) => w -> Either MLSEnumError a
toMLSEnum' :: forall a w.
(Bounded a, Enum a, Integral w) =>
w -> Either MLSEnumError a
toMLSEnum' w
w = case w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral w
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 of
Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> MLSEnumError -> Either MLSEnumError a
forall a b. a -> Either a b
Left MLSEnumError
MLSEnumInvalid
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< forall a. Enum a => a -> Int
fromEnum @a a
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> forall a. Enum a => a -> Int
fromEnum @a a
forall a. Bounded a => a
maxBound -> MLSEnumError -> Either MLSEnumError a
forall a b. a -> Either a b
Left (Int -> MLSEnumError
MLSEnumUnknown Int
n)
| Bool
otherwise -> a -> Either MLSEnumError a
forall a. a -> Either MLSEnumError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> a
forall a. Enum a => Int -> a
toEnum Int
n)
toMLSEnum :: forall a w f. (Bounded a, Enum a, MonadFail f, Integral w) => String -> w -> f a
toMLSEnum :: forall a w (f :: * -> *).
(Bounded a, Enum a, MonadFail f, Integral w) =>
String -> w -> f a
toMLSEnum String
name = (MLSEnumError -> f a) -> (a -> f a) -> Either MLSEnumError a -> f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MLSEnumError -> f a
err a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MLSEnumError a -> f a)
-> (w -> Either MLSEnumError a) -> w -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Either MLSEnumError a
forall a w.
(Bounded a, Enum a, Integral w) =>
w -> Either MLSEnumError a
toMLSEnum'
where
err :: MLSEnumError -> f a
err (MLSEnumUnknown Int
value) = String -> f a
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f a) -> String -> f a
forall a b. (a -> b) -> a -> b
$ String
"Unknown " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
value
err MLSEnumError
MLSEnumInvalid = String -> f a
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f a) -> String -> f a
forall a b. (a -> b) -> a -> b
$ String
"Invalid " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name
fromMLSEnum :: (Integral w, Enum a) => a -> w
fromMLSEnum :: forall w a. (Integral w, Enum a) => a -> w
fromMLSEnum = Int -> w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> w) -> (a -> Int) -> a -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum
instance ParseMLS Word8 where parseMLS :: Get Word8
parseMLS = Get Word8
forall t. Binary t => Get t
get
instance ParseMLS Word16 where parseMLS :: Get Word16
parseMLS = Get Word16
forall t. Binary t => Get t
get
instance ParseMLS Word32 where parseMLS :: Get Word32
parseMLS = Get Word32
forall t. Binary t => Get t
get
instance ParseMLS Word64 where parseMLS :: Get Word64
parseMLS = Get Word64
forall t. Binary t => Get t
get
instance SerialiseMLS Word8 where serialiseMLS :: Word8 -> Put
serialiseMLS = Word8 -> Put
forall t. Binary t => t -> Put
put
instance SerialiseMLS Word16 where serialiseMLS :: Word16 -> Put
serialiseMLS = Word16 -> Put
forall t. Binary t => t -> Put
put
instance SerialiseMLS Word32 where serialiseMLS :: Word32 -> Put
serialiseMLS = Word32 -> Put
forall t. Binary t => t -> Put
put
instance SerialiseMLS Word64 where serialiseMLS :: Word64 -> Put
serialiseMLS = Word64 -> Put
forall t. Binary t => t -> Put
put
encodeMLS :: (SerialiseMLS a) => a -> LByteString
encodeMLS :: forall a. SerialiseMLS a => a -> ByteString
encodeMLS = Put -> ByteString
runPut (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS
encodeMLS' :: (SerialiseMLS a) => a -> ByteString
encodeMLS' :: forall a. SerialiseMLS a => a -> ByteString
encodeMLS' = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. SerialiseMLS a => a -> ByteString
encodeMLS
decodeMLS :: (ParseMLS a) => LByteString -> Either Text a
decodeMLS :: forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS = Get a -> ByteString -> Either Text a
forall a. Get a -> ByteString -> Either Text a
decodeMLSWith Get a
forall a. ParseMLS a => Get a
parseMLS
decodeMLS' :: (ParseMLS a) => ByteString -> Either Text a
decodeMLS' :: forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS' = ByteString -> Either Text a
forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS (ByteString -> Either Text a)
-> (ByteString -> ByteString) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict
decodeMLSWith :: Get a -> LByteString -> Either Text a
decodeMLSWith :: forall a. Get a -> ByteString -> Either Text a
decodeMLSWith Get a
p ByteString
b = case Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail Get a
p ByteString
b of
Left (ByteString
_, Int64
_, String
msg) -> Text -> Either Text a
forall a b. a -> Either a b
Left (String -> Text
Text.pack String
msg)
Right (ByteString
remainder, Int64
pos, a
x)
| ByteString -> Bool
LBS.null ByteString
remainder -> a -> Either Text a
forall a b. b -> Either a b
Right a
x
| Bool
otherwise -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Trailing data at position " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int64 -> String
forall a. Show a => a -> String
show Int64
pos)
decodeMLSWith' :: Get a -> ByteString -> Either Text a
decodeMLSWith' :: forall a. Get a -> ByteString -> Either Text a
decodeMLSWith' Get a
p = Get a -> ByteString -> Either Text a
forall a. Get a -> ByteString -> Either Text a
decodeMLSWith Get a
p (ByteString -> Either Text a)
-> (ByteString -> ByteString) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict
data RawMLS a = RawMLS
{ forall a. RawMLS a -> ByteString
raw :: ByteString,
forall a. RawMLS a -> a
value :: a
}
deriving stock (RawMLS a -> RawMLS a -> Bool
(RawMLS a -> RawMLS a -> Bool)
-> (RawMLS a -> RawMLS a -> Bool) -> Eq (RawMLS a)
forall a. Eq a => RawMLS a -> RawMLS a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => RawMLS a -> RawMLS a -> Bool
== :: RawMLS a -> RawMLS a -> Bool
$c/= :: forall a. Eq a => RawMLS a -> RawMLS a -> Bool
/= :: RawMLS a -> RawMLS a -> Bool
Eq, Int -> RawMLS a -> ShowS
[RawMLS a] -> ShowS
RawMLS a -> String
(Int -> RawMLS a -> ShowS)
-> (RawMLS a -> String) -> ([RawMLS a] -> ShowS) -> Show (RawMLS a)
forall a. Show a => Int -> RawMLS a -> ShowS
forall a. Show a => [RawMLS a] -> ShowS
forall a. Show a => RawMLS a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RawMLS a -> ShowS
showsPrec :: Int -> RawMLS a -> ShowS
$cshow :: forall a. Show a => RawMLS a -> String
show :: RawMLS a -> String
$cshowList :: forall a. Show a => [RawMLS a] -> ShowS
showList :: [RawMLS a] -> ShowS
Show, (forall m. Monoid m => RawMLS m -> m)
-> (forall m a. Monoid m => (a -> m) -> RawMLS a -> m)
-> (forall m a. Monoid m => (a -> m) -> RawMLS a -> m)
-> (forall a b. (a -> b -> b) -> b -> RawMLS a -> b)
-> (forall a b. (a -> b -> b) -> b -> RawMLS a -> b)
-> (forall b a. (b -> a -> b) -> b -> RawMLS a -> b)
-> (forall b a. (b -> a -> b) -> b -> RawMLS a -> b)
-> (forall a. (a -> a -> a) -> RawMLS a -> a)
-> (forall a. (a -> a -> a) -> RawMLS a -> a)
-> (forall a. RawMLS a -> [a])
-> (forall a. RawMLS a -> Bool)
-> (forall a. RawMLS a -> Int)
-> (forall a. Eq a => a -> RawMLS a -> Bool)
-> (forall a. Ord a => RawMLS a -> a)
-> (forall a. Ord a => RawMLS a -> a)
-> (forall a. Num a => RawMLS a -> a)
-> (forall a. Num a => RawMLS a -> a)
-> Foldable RawMLS
forall a. Eq a => a -> RawMLS a -> Bool
forall a. Num a => RawMLS a -> a
forall a. Ord a => RawMLS a -> a
forall m. Monoid m => RawMLS m -> m
forall a. RawMLS a -> Bool
forall a. RawMLS a -> Int
forall a. RawMLS a -> [a]
forall a. (a -> a -> a) -> RawMLS a -> a
forall m a. Monoid m => (a -> m) -> RawMLS a -> m
forall b a. (b -> a -> b) -> b -> RawMLS a -> b
forall a b. (a -> b -> b) -> b -> RawMLS a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => RawMLS m -> m
fold :: forall m. Monoid m => RawMLS m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> RawMLS a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> RawMLS a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> RawMLS a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> RawMLS a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> RawMLS a -> b
foldr :: forall a b. (a -> b -> b) -> b -> RawMLS a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> RawMLS a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> RawMLS a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> RawMLS a -> b
foldl :: forall b a. (b -> a -> b) -> b -> RawMLS a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> RawMLS a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> RawMLS a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> RawMLS a -> a
foldr1 :: forall a. (a -> a -> a) -> RawMLS a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> RawMLS a -> a
foldl1 :: forall a. (a -> a -> a) -> RawMLS a -> a
$ctoList :: forall a. RawMLS a -> [a]
toList :: forall a. RawMLS a -> [a]
$cnull :: forall a. RawMLS a -> Bool
null :: forall a. RawMLS a -> Bool
$clength :: forall a. RawMLS a -> Int
length :: forall a. RawMLS a -> Int
$celem :: forall a. Eq a => a -> RawMLS a -> Bool
elem :: forall a. Eq a => a -> RawMLS a -> Bool
$cmaximum :: forall a. Ord a => RawMLS a -> a
maximum :: forall a. Ord a => RawMLS a -> a
$cminimum :: forall a. Ord a => RawMLS a -> a
minimum :: forall a. Ord a => RawMLS a -> a
$csum :: forall a. Num a => RawMLS a -> a
sum :: forall a. Num a => RawMLS a -> a
$cproduct :: forall a. Num a => RawMLS a -> a
product :: forall a. Num a => RawMLS a -> a
Foldable)
instance (Arbitrary a, SerialiseMLS a) => Arbitrary (RawMLS a) where
arbitrary :: Gen (RawMLS a)
arbitrary = a -> RawMLS a
forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS (a -> RawMLS a) -> Gen a -> Gen (RawMLS a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary
rawMLSSchema :: Text -> (ByteString -> Either Text a) -> ValueSchema NamedSwaggerDoc (RawMLS a)
rawMLSSchema :: forall a.
Text
-> (ByteString -> Either Text a)
-> ValueSchema NamedSwaggerDoc (RawMLS a)
rawMLSSchema Text
name ByteString -> Either Text a
p =
(ByteString -> Text
toBase64Text (ByteString -> Text)
-> (RawMLS a -> ByteString) -> RawMLS a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawMLS a -> ByteString
forall a. RawMLS a -> ByteString
raw)
(RawMLS a -> Text)
-> SchemaP NamedSwaggerDoc Value Value Text (RawMLS a)
-> SchemaP NamedSwaggerDoc Value Value (RawMLS a) (RawMLS a)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> (Text -> Either String (RawMLS a))
-> SchemaP NamedSwaggerDoc Value Value Text (RawMLS a)
forall a.
Text
-> (Text -> Either String a)
-> SchemaP NamedSwaggerDoc Value Value Text a
parsedText Text
name ((ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
forall a.
(ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
rawMLSFromText ByteString -> Either Text a
p)
mlsSwagger :: Text -> S.NamedSchema
mlsSwagger :: Text -> NamedSchema
mlsSwagger Text
name =
Maybe Text -> Schema -> NamedSchema
S.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
S.description
((Maybe Text -> Identity (Maybe Text))
-> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"This object can only be parsed in TLS format. \
\Please refer to the MLS specification for details."
rawMLSFromText :: (ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
rawMLSFromText :: forall a.
(ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
rawMLSFromText ByteString -> Either Text a
p Text
txt = do
ByteString
mlsData <- Text -> Either String ByteString
fromBase64Text Text
txt
a
value <- (Text -> String) -> Either Text a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> String
Text.unpack (ByteString -> Either Text a
p ByteString
mlsData)
RawMLS a -> Either String (RawMLS a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawMLS a -> Either String (RawMLS a))
-> RawMLS a -> Either String (RawMLS a)
forall a b. (a -> b) -> a -> b
$ ByteString -> a -> RawMLS a
forall a. ByteString -> a -> RawMLS a
RawMLS ByteString
mlsData a
value
instance (S.ToSchema a) => S.ToSchema (RawMLS a) where
declareNamedSchema :: Proxy (RawMLS a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (RawMLS a)
_ = Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
S.declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
instance (ParseMLS a) => FromJSON (RawMLS a) where
parseJSON :: Value -> Parser (RawMLS a)
parseJSON =
String -> (Text -> Parser (RawMLS a)) -> Value -> Parser (RawMLS a)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Base64 MLS object" ((Text -> Parser (RawMLS a)) -> Value -> Parser (RawMLS a))
-> (Text -> Parser (RawMLS a)) -> Value -> Parser (RawMLS a)
forall a b. (a -> b) -> a -> b
$
(String -> Parser (RawMLS a))
-> (RawMLS a -> Parser (RawMLS a))
-> Either String (RawMLS a)
-> Parser (RawMLS a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser (RawMLS a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail RawMLS a -> Parser (RawMLS a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (RawMLS a) -> Parser (RawMLS a))
-> (Text -> Either String (RawMLS a)) -> Text -> Parser (RawMLS a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
forall a.
(ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
rawMLSFromText ByteString -> Either Text a
forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS'
parseRawMLS :: Get a -> Get (RawMLS a)
parseRawMLS :: forall a. Get a -> Get (RawMLS a)
parseRawMLS Get a
p = do
Int64
begin <- Get Int64
bytesRead
(a
x, Int64
end) <- Get (a, Int64) -> Get (a, Int64)
forall a. Get a -> Get a
lookAhead (Get (a, Int64) -> Get (a, Int64))
-> Get (a, Int64) -> Get (a, Int64)
forall a b. (a -> b) -> a -> b
$ (,) (a -> Int64 -> (a, Int64)) -> Get a -> Get (Int64 -> (a, Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
p Get (Int64 -> (a, Int64)) -> Get Int64 -> Get (a, Int64)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int64
bytesRead
ByteString
raw <- Int -> Get ByteString
getByteString (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
end Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
begin))
RawMLS a -> Get (RawMLS a)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawMLS a -> Get (RawMLS a)) -> RawMLS a -> Get (RawMLS a)
forall a b. (a -> b) -> a -> b
$ ByteString -> a -> RawMLS a
forall a. ByteString -> a -> RawMLS a
RawMLS ByteString
raw a
x
instance (ParseMLS a) => ParseMLS (RawMLS a) where
parseMLS :: Get (RawMLS a)
parseMLS = Get a -> Get (RawMLS a)
forall a. Get a -> Get (RawMLS a)
parseRawMLS Get a
forall a. ParseMLS a => Get a
parseMLS
instance SerialiseMLS (RawMLS a) where
serialiseMLS :: RawMLS a -> Put
serialiseMLS = ByteString -> Put
putByteString (ByteString -> Put) -> (RawMLS a -> ByteString) -> RawMLS a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawMLS a -> ByteString
forall a. RawMLS a -> ByteString
raw
mkRawMLS :: (SerialiseMLS a) => a -> RawMLS a
mkRawMLS :: forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS a
x = ByteString -> a -> RawMLS a
forall a. ByteString -> a -> RawMLS a
RawMLS (ByteString -> ByteString
LBS.toStrict (Put -> ByteString
runPut (a -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS a
x))) a
x
traceMLS :: (Show a) => String -> Get a -> Get a
traceMLS :: forall a. Show a => String -> Get a -> Get a
traceMLS String
l Get a
g = do
Int64
begin <- Get Int64
bytesRead
a
r <- Get a
g
Int64
end <- Get Int64
bytesRead
String -> Get ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
l String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
begin String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
end String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
r
a -> Get a
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r