{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

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)

-- | Parse a value encoded using the "TLS presentation" format.
class ParseMLS a where
  parseMLS :: Get a

-- | Convert a value to "TLS presentation" format.
class SerialiseMLS a where
  serialiseMLS :: a -> Put

-- | An integer value serialised with a variable-size encoding.
--
-- The underlying Word32 must be strictly less than 2^30.
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)

-- From the MLS spec:
--
-- Prefix | Length | Usable Bits | Min | Max
-- -------+--------+-------------+-----+---------
-- 00       1        6             0     63
-- 01       2        14            64    16383
-- 10       4        30            16384 1073741823
-- 11       invalid  -             -     -
--
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

-- | Parse a positive tag for an enumeration. The value 0 is considered
-- "reserved", and all other values are shifted down by 1 to get the
-- corresponding enumeration index. This makes it possible to parse enumeration
-- types that don't contain an explicit constructor for a "reserved" value.
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

-- | Encode an MLS value to a lazy bytestring.
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

-- | Decode an MLS value from a lazy bytestring. Return an error message in case of failure.
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

-- | Decode an MLS value from a lazy bytestring given a custom parser.
-- Return an error message in case of failure.
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

-- | An MLS value together with its serialisation.
--
-- This can be used whenever we need to parse an object, but at the same time
-- retain the original serialised bytes (e.g. for signature verification, or to
-- forward them verbatim).
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

-- | A schema for a raw MLS object.
--
-- This can be used for embedding MLS objects into JSON. It expresses the
-- object as a base64-encoded string containing the raw bytes of its native MLS
-- serialisation.
--
-- Note that a 'ValueSchema' for the underlying type @a@ is /not/ required.
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'

-- | Parse an MLS object, but keep the raw bytes as well.
parseRawMLS :: Get a -> Get (RawMLS a)
parseRawMLS :: forall a. Get a -> Get (RawMLS a)
parseRawMLS Get a
p = do
  -- mark the starting position
  Int64
begin <- Get Int64
bytesRead
  -- read value, but don't consume input, and mark final position
  (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
  -- now just get the input data
  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))
  -- construct RawMLS value
  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