{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Module: Temporal.Payload
Description: Payloads are the binary data that is sent to and from the Temporal Server.

A Payload represents binary data such as input and output from Activities and Workflows. Payloads contain metadata that describe the binary data, such as its data type or other arbitrary values for use by custom encoders/converters.

When processed through the SDK, the default Data Converter serializes your data/value to a Payload before sending it to the Temporal Server. The default Data Converter processes supported type values to Payloads, and you can create a custom Payload Converter to convert your custom object types.

You can additionally apply custom codecs (such as for encryption or compression) on your Payloads to wrap them into new encoded Payloads.
-}
module Temporal.Payload (
  Payload (..),
  Codec (..),
  JSON (..),
  Null (..),
  Binary (..),
  Protobuf (..),
  Zlib (..),
  zlib,
  applyPayloads,
  Around (..),
  mkPayloadProcessor,
  addPayloadProcessor,
  PayloadProcessor (..),
  ApplyPayloads,
  ArgsOf,
  ResultOf,
  (:->:),
  convertToProtoPayload,
  convertFromProtoPayload,

  -- * Vararg manipulation
  VarArgs (..),
  hoistResult,
  foldMapArgs,
  foldMArgs,
  foldMArgs_,
  withArgs,
  UnencodedPayload,
  processorEncodePayloads,
  processorDecodePayloads,
  AllArgs,
  GatherArgs,
  GatherArgsOf,
  FunctionSupportsCodec,
  FunctionSupportsCodec',
  ValueError (..),
) where

import Codec.Compression.Zlib.Internal hiding (Format (..))
import Control.Exception (Exception, throwIO)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson hiding (decode, encode)
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Base64 (decodeBase64, encodeBase64)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as BL
import Data.Kind
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.ProtoLens (Message (..), defMessage)
import Data.ProtoLens.Encoding (decodeMessage, encodeMessage)
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Encoding as Text
import Data.Typeable
import qualified Data.Vector as V
import qualified Data.Vector.Fusion.Bundle as B
import qualified Data.Vector.Generic as VG
import GHC.TypeLits
import Language.Haskell.TH.Syntax (Lift)
import Lens.Family2
import qualified Proto.Temporal.Api.Common.V1.Message as Proto (Payload)
import qualified Proto.Temporal.Api.Common.V1.Message_Fields as Proto (data', metadata)


-- | Used to denote that a payload either failed to encode or decode
data ValueError
  = ValueError String
  deriving stock (ValueError -> ValueError -> Bool
(ValueError -> ValueError -> Bool)
-> (ValueError -> ValueError -> Bool) -> Eq ValueError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValueError -> ValueError -> Bool
== :: ValueError -> ValueError -> Bool
$c/= :: ValueError -> ValueError -> Bool
/= :: ValueError -> ValueError -> Bool
Eq, Int -> ValueError -> ShowS
[ValueError] -> ShowS
ValueError -> String
(Int -> ValueError -> ShowS)
-> (ValueError -> String)
-> ([ValueError] -> ShowS)
-> Show ValueError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueError -> ShowS
showsPrec :: Int -> ValueError -> ShowS
$cshow :: ValueError -> String
show :: ValueError -> String
$cshowList :: [ValueError] -> ShowS
showList :: [ValueError] -> ShowS
Show)


instance Exception ValueError


{- * Parameter serialization

We want to be able to serialize & deserialize the parameters of a function using an arbitrary serialization code.
We do this by gathering the order of the parameters as a type-level list, then fold over the type level list to
build a function with the same parameters that outputs a list of serialized params.

To deserialize, we do the inverse– we progressively apply the args of the function by consuming serialized params
as we go. If there are not enough or too many params, we fail.
-}


-- | We want to be able to serialize & deserialize the parameters of a function using an arbitrary serialization format.
class Codec fmt a where
  -- | Similar to a content-type header, this is a string that identifies the format of the payload.
  -- it will be set on the 'encoding' metadata field of the payload.
  encoding :: fmt -> Proxy a -> ByteString


  messageType :: fmt -> a -> ByteString
  default messageType :: (Typeable a) => fmt -> a -> ByteString
  messageType fmt
_ a
_ = String -> ByteString
C.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  encode :: fmt -> a -> IO Payload
  decode :: fmt -> Payload -> IO (Either String a)


insertStandardMetadata :: Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata :: forall fmt a. Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata fmt
fmt a
x (Payload ByteString
d Map Text ByteString
m) =
  ByteString -> Map Text ByteString -> Payload
Payload ByteString
d (Map Text ByteString -> Payload) -> Map Text ByteString -> Payload
forall a b. (a -> b) -> a -> b
$
    Map Text ByteString
m
      Map Text ByteString -> Map Text ByteString -> Map Text ByteString
forall a. Semigroup a => a -> a -> a
<> [(Text, ByteString)] -> Map Text ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"encoding", fmt -> Proxy a -> ByteString
forall fmt a. Codec fmt a => fmt -> Proxy a -> ByteString
encoding fmt
fmt (Proxy a -> ByteString) -> Proxy a -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Proxy a
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
        , (Text
"messageType", fmt -> a -> ByteString
forall fmt a. Codec fmt a => fmt -> a -> ByteString
messageType fmt
fmt a
x)
        ]


data JSON = JSON
  deriving stock (JSON -> JSON -> Bool
(JSON -> JSON -> Bool) -> (JSON -> JSON -> Bool) -> Eq JSON
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSON -> JSON -> Bool
== :: JSON -> JSON -> Bool
$c/= :: JSON -> JSON -> Bool
/= :: JSON -> JSON -> Bool
Eq, Int -> JSON -> ShowS
[JSON] -> ShowS
JSON -> String
(Int -> JSON -> ShowS)
-> (JSON -> String) -> ([JSON] -> ShowS) -> Show JSON
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JSON -> ShowS
showsPrec :: Int -> JSON -> ShowS
$cshow :: JSON -> String
show :: JSON -> String
$cshowList :: [JSON] -> ShowS
showList :: [JSON] -> ShowS
Show, (forall (m :: * -> *). Quote m => JSON -> m Exp)
-> (forall (m :: * -> *). Quote m => JSON -> Code m JSON)
-> Lift JSON
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => JSON -> m Exp
forall (m :: * -> *). Quote m => JSON -> Code m JSON
$clift :: forall (m :: * -> *). Quote m => JSON -> m Exp
lift :: forall (m :: * -> *). Quote m => JSON -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => JSON -> Code m JSON
liftTyped :: forall (m :: * -> *). Quote m => JSON -> Code m JSON
Lift)


instance (Typeable a, Aeson.ToJSON a, Aeson.FromJSON a) => Codec JSON a where
  encoding :: JSON -> Proxy a -> ByteString
encoding JSON
_ Proxy a
_ = ByteString
"json/plain"
  encode :: JSON -> a -> IO Payload
encode JSON
c a
x = Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> IO Payload) -> Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ JSON -> a -> Payload -> Payload
forall fmt a. Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata JSON
c a
x (Payload -> Payload) -> Payload -> Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Map Text ByteString -> Payload
Payload (LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode a
x) Map Text ByteString
forall a. Monoid a => a
mempty
  decode :: JSON -> Payload -> IO (Either String a)
decode JSON
_ = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> (Payload -> Either String a) -> Payload -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' (ByteString -> Either String a)
-> (Payload -> ByteString) -> Payload -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload -> ByteString
payloadData


data Null = Null
  deriving stock (Null -> Null -> Bool
(Null -> Null -> Bool) -> (Null -> Null -> Bool) -> Eq Null
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Null -> Null -> Bool
== :: Null -> Null -> Bool
$c/= :: Null -> Null -> Bool
/= :: Null -> Null -> Bool
Eq, Int -> Null -> ShowS
[Null] -> ShowS
Null -> String
(Int -> Null -> ShowS)
-> (Null -> String) -> ([Null] -> ShowS) -> Show Null
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Null -> ShowS
showsPrec :: Int -> Null -> ShowS
$cshow :: Null -> String
show :: Null -> String
$cshowList :: [Null] -> ShowS
showList :: [Null] -> ShowS
Show, (forall (m :: * -> *). Quote m => Null -> m Exp)
-> (forall (m :: * -> *). Quote m => Null -> Code m Null)
-> Lift Null
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Null -> m Exp
forall (m :: * -> *). Quote m => Null -> Code m Null
$clift :: forall (m :: * -> *). Quote m => Null -> m Exp
lift :: forall (m :: * -> *). Quote m => Null -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Null -> Code m Null
liftTyped :: forall (m :: * -> *). Quote m => Null -> Code m Null
Lift)


instance Codec Null () where
  encoding :: Null -> Proxy () -> ByteString
encoding Null
_ Proxy ()
_ = ByteString
"binary/null"
  encode :: Null -> () -> IO Payload
encode Null
c ()
x = Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> IO Payload) -> Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ Null -> () -> Payload -> Payload
forall fmt a. Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata Null
c ()
x (Payload -> Payload) -> Payload -> Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Map Text ByteString -> Payload
Payload ByteString
forall a. Monoid a => a
mempty Map Text ByteString
forall a. Monoid a => a
mempty
  decode :: Null -> Payload -> IO (Either String ())
decode Null
_ Payload
_ = Either String () -> IO (Either String ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()


{- | Direct binary serialization.

A generalized instance like the one for JSON is not provided because
there are many possible binary serialization formats and libraries.

You can provide a simple version of this instance for your own codebase
using something like the cereal package:

> import Data.Serialize (Serialize)
> import qualified Data.Serialize as Serialize
> instance {\-# OVERLAPPABLE #-\} (Typeable a, Serialize a) => Codec Binary a where
>   encodingType _ _ = "binary/plain"
>   encodePayload _ x = Serialize.encode x
>   decode _ = Serialize.decode . inputPayloadData
-}
data Binary = Binary
  deriving stock (Binary -> Binary -> Bool
(Binary -> Binary -> Bool)
-> (Binary -> Binary -> Bool) -> Eq Binary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Binary -> Binary -> Bool
== :: Binary -> Binary -> Bool
$c/= :: Binary -> Binary -> Bool
/= :: Binary -> Binary -> Bool
Eq, Int -> Binary -> ShowS
[Binary] -> ShowS
Binary -> String
(Int -> Binary -> ShowS)
-> (Binary -> String) -> ([Binary] -> ShowS) -> Show Binary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Binary -> ShowS
showsPrec :: Int -> Binary -> ShowS
$cshow :: Binary -> String
show :: Binary -> String
$cshowList :: [Binary] -> ShowS
showList :: [Binary] -> ShowS
Show, (forall (m :: * -> *). Quote m => Binary -> m Exp)
-> (forall (m :: * -> *). Quote m => Binary -> Code m Binary)
-> Lift Binary
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Binary -> m Exp
forall (m :: * -> *). Quote m => Binary -> Code m Binary
$clift :: forall (m :: * -> *). Quote m => Binary -> m Exp
lift :: forall (m :: * -> *). Quote m => Binary -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Binary -> Code m Binary
liftTyped :: forall (m :: * -> *). Quote m => Binary -> Code m Binary
Lift)


instance Codec Binary ByteString where
  encoding :: Binary -> Proxy ByteString -> ByteString
encoding Binary
_ Proxy ByteString
_ = ByteString
"binary/plain"
  encode :: Binary -> ByteString -> IO Payload
encode Binary
c ByteString
x = Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> IO Payload) -> Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ Binary -> ByteString -> Payload -> Payload
forall fmt a. Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata Binary
c ByteString
x (Payload -> Payload) -> Payload -> Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Map Text ByteString -> Payload
Payload ByteString
x Map Text ByteString
forall a. Monoid a => a
mempty
  decode :: Binary -> Payload -> IO (Either String ByteString)
decode Binary
_ = Either String ByteString -> IO (Either String ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> IO (Either String ByteString))
-> (Payload -> Either String ByteString)
-> Payload
-> IO (Either String ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (Payload -> ByteString) -> Payload -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload -> ByteString
payloadData


data Protobuf = Protobuf
  deriving stock (Protobuf -> Protobuf -> Bool
(Protobuf -> Protobuf -> Bool)
-> (Protobuf -> Protobuf -> Bool) -> Eq Protobuf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Protobuf -> Protobuf -> Bool
== :: Protobuf -> Protobuf -> Bool
$c/= :: Protobuf -> Protobuf -> Bool
/= :: Protobuf -> Protobuf -> Bool
Eq, Int -> Protobuf -> ShowS
[Protobuf] -> ShowS
Protobuf -> String
(Int -> Protobuf -> ShowS)
-> (Protobuf -> String) -> ([Protobuf] -> ShowS) -> Show Protobuf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Protobuf -> ShowS
showsPrec :: Int -> Protobuf -> ShowS
$cshow :: Protobuf -> String
show :: Protobuf -> String
$cshowList :: [Protobuf] -> ShowS
showList :: [Protobuf] -> ShowS
Show, (forall (m :: * -> *). Quote m => Protobuf -> m Exp)
-> (forall (m :: * -> *). Quote m => Protobuf -> Code m Protobuf)
-> Lift Protobuf
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Protobuf -> m Exp
forall (m :: * -> *). Quote m => Protobuf -> Code m Protobuf
$clift :: forall (m :: * -> *). Quote m => Protobuf -> m Exp
lift :: forall (m :: * -> *). Quote m => Protobuf -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Protobuf -> Code m Protobuf
liftTyped :: forall (m :: * -> *). Quote m => Protobuf -> Code m Protobuf
Lift)


instance (Message a) => Codec Protobuf a where
  messageType :: Protobuf -> a -> ByteString
messageType Protobuf
_ a
x = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy a -> Text
forall msg. Message msg => Proxy msg -> Text
messageName (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ a -> Proxy a
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  encoding :: Protobuf -> Proxy a -> ByteString
encoding Protobuf
_ Proxy a
_ = ByteString
"binary/protobuf"
  encode :: Protobuf -> a -> IO Payload
encode Protobuf
c a
x = Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> IO Payload) -> Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ Protobuf -> a -> Payload -> Payload
forall fmt a. Codec fmt a => fmt -> a -> Payload -> Payload
insertStandardMetadata Protobuf
c a
x (Payload -> Payload) -> Payload -> Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Map Text ByteString -> Payload
Payload (a -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage a
x) Map Text ByteString
forall a. Monoid a => a
mempty
  decode :: Protobuf -> Payload -> IO (Either String a)
decode Protobuf
_ = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> (Payload -> Either String a) -> Payload -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall msg. Message msg => ByteString -> Either String msg
decodeMessage (ByteString -> Either String a)
-> (Payload -> ByteString) -> Payload -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload -> ByteString
payloadData


data Zlib = Zlib
  { Zlib -> Int
minimumEncodingSize :: Int
  -- ^ Skip compression when the size of the response body is
  -- below this amount of bytes (default: 860.)
  --
  -- /Setting this option to less than 150 will actually increase/
  -- /the size of outgoing data if its original size is less than 150 bytes/.
  , Zlib -> CompressParams
compressParams :: CompressParams
  , Zlib -> DecompressParams
decompressParams :: DecompressParams
  }


zlib :: Zlib
zlib :: Zlib
zlib = Int -> CompressParams -> DecompressParams -> Zlib
Zlib Int
860 CompressParams
defaultCompressParams DecompressParams
defaultDecompressParams


instance Codec Zlib Payload where
  encoding :: Zlib -> Proxy Payload -> ByteString
encoding Zlib
_ Proxy Payload
_ = ByteString
"binary/zlib"


  -- TODO, if we keep the original compression size, we can allocate the right size buffer for the decompressed data.
  encode :: Zlib -> Payload -> IO Payload
encode Zlib {Int
DecompressParams
CompressParams
minimumEncodingSize :: Zlib -> Int
compressParams :: Zlib -> CompressParams
decompressParams :: Zlib -> DecompressParams
minimumEncodingSize :: Int
compressParams :: CompressParams
decompressParams :: DecompressParams
..} Payload
p =
    if ByteString -> Int
BS.length ByteString
msg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minimumEncodingSize Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
compressed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
BS.length ByteString
msg
      then Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> IO Payload) -> Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Map Text ByteString -> Payload
Payload ByteString
compressed (Text -> ByteString -> Map Text ByteString
forall k a. k -> a -> Map k a
Map.singleton Text
"encoding" ByteString
"binary/zlib")
      else Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload
p
    where
      msg :: ByteString
msg = Payload -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage (Payload -> ByteString) -> Payload -> ByteString
forall a b. (a -> b) -> a -> b
$ Payload -> Payload
convertToProtoPayload Payload
p
      compressed :: ByteString
compressed = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Format -> CompressParams -> LazyByteString -> LazyByteString
compress Format
zlibFormat CompressParams
compressParams (LazyByteString -> LazyByteString)
-> LazyByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> LazyByteString
BL.fromStrict Payload
p.payloadData
  decode :: Zlib -> Payload -> IO (Either String Payload)
decode Zlib {Int
DecompressParams
CompressParams
minimumEncodingSize :: Zlib -> Int
compressParams :: Zlib -> CompressParams
decompressParams :: Zlib -> DecompressParams
minimumEncodingSize :: Int
compressParams :: CompressParams
decompressParams :: DecompressParams
..} Payload
p = case Payload
p.payloadMetadata Map Text ByteString -> Text -> Maybe ByteString
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
"encoding" of
    -- TODO, use `decompressIO` instead of `decompress`  so we can return the error in the Left case.
    Just ByteString
"binary/zlib" ->
      Either String Payload -> IO (Either String Payload)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Payload -> IO (Either String Payload))
-> Either String Payload -> IO (Either String Payload)
forall a b. (a -> b) -> a -> b
$
        (Payload -> Payload)
-> Either String Payload -> Either String Payload
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Payload -> Payload
convertFromProtoPayload (Either String Payload -> Either String Payload)
-> Either String Payload -> Either String Payload
forall a b. (a -> b) -> a -> b
$
          ByteString -> Either String Payload
forall msg. Message msg => ByteString -> Either String msg
decodeMessage (ByteString -> Either String Payload)
-> ByteString -> Either String Payload
forall a b. (a -> b) -> a -> b
$
            LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
              Format -> DecompressParams -> LazyByteString -> LazyByteString
decompress Format
zlibFormat DecompressParams
decompressParams (LazyByteString -> LazyByteString)
-> LazyByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$
                ByteString -> LazyByteString
BL.fromStrict Payload
p.payloadData
    Maybe ByteString
_ -> Either String Payload -> IO (Either String Payload)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Payload -> IO (Either String Payload))
-> Either String Payload -> IO (Either String Payload)
forall a b. (a -> b) -> a -> b
$ Payload -> Either String Payload
forall a b. b -> Either a b
Right Payload
p


{- | A codec that post-processes the payload after encoding and pre-processes before decoding.

Combining multiple 'PayloadProcessor's will apply them in the order that they are added.
For example, if you want to compress and then encrypt, you would add the compression processor
first, then the encryption processor.
-}
data PayloadProcessor = PayloadProcessor
  { PayloadProcessor -> Payload -> IO Payload
payloadProcessorEncode :: Payload -> IO Payload
  , PayloadProcessor -> Payload -> IO (Either String Payload)
payloadProcessorDecode :: Payload -> IO (Either String Payload)
  }


-- TODO, need to make sure to unit test this before using it. The ordering guarantees have me confused.
-- instance Semigroup PayloadProcessor where
--   PayloadProcessor e1 d1 <> PayloadProcessor e2 d2 = PayloadProcessor
--     { PayloadProcessorEncode =
--     , PayloadProcessorDecode =
--     }
-- instance Monoid PayloadProcessor where
--   mempty = PayloadProcessor pure (pure . Right)

mkPayloadProcessor :: Codec fmt Payload => fmt -> PayloadProcessor
mkPayloadProcessor :: forall fmt. Codec fmt Payload => fmt -> PayloadProcessor
mkPayloadProcessor fmt
fmt =
  PayloadProcessor
    { payloadProcessorEncode :: Payload -> IO Payload
payloadProcessorEncode = fmt -> Payload -> IO Payload
forall fmt a. Codec fmt a => fmt -> a -> IO Payload
encode fmt
fmt
    , payloadProcessorDecode :: Payload -> IO (Either String Payload)
payloadProcessorDecode = fmt -> Payload -> IO (Either String Payload)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode fmt
fmt
    }


addPayloadProcessor :: Codec fmt Payload => fmt -> PayloadProcessor -> PayloadProcessor
addPayloadProcessor :: forall fmt.
Codec fmt Payload =>
fmt -> PayloadProcessor -> PayloadProcessor
addPayloadProcessor fmt
fmt PayloadProcessor {Payload -> IO (Either String Payload)
Payload -> IO Payload
payloadProcessorEncode :: PayloadProcessor -> Payload -> IO Payload
payloadProcessorDecode :: PayloadProcessor -> Payload -> IO (Either String Payload)
payloadProcessorEncode :: Payload -> IO Payload
payloadProcessorDecode :: Payload -> IO (Either String Payload)
..} =
  PayloadProcessor
    { payloadProcessorEncode :: Payload -> IO Payload
payloadProcessorEncode = \Payload
p -> do
        p' <- Payload -> IO Payload
payloadProcessorEncode Payload
p
        encode fmt p'
    , payloadProcessorDecode :: Payload -> IO (Either String Payload)
payloadProcessorDecode = \Payload
p -> do
        p' <- fmt -> Payload -> IO (Either String Payload)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode fmt
fmt Payload
p
        case p' of
          Left String
err -> Either String Payload -> IO (Either String Payload)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Payload -> IO (Either String Payload))
-> Either String Payload -> IO (Either String Payload)
forall a b. (a -> b) -> a -> b
$ String -> Either String Payload
forall a b. a -> Either a b
Left String
err
          Right Payload
ok -> Payload -> IO (Either String Payload)
payloadProcessorDecode Payload
ok
    }


{- | A codec that uses the base codec for actually encoding and decoding, but
supports additional pre- and post-processing. This is useful for adding
compression, encryption, or other transformations to an existing codec.
-}
data Around base = Around
  { forall base. Around base -> PayloadProcessor
around :: PayloadProcessor
  , forall base. Around base -> base
baseCodec :: base
  }


instance (Typeable a, Codec base a) => Codec (Around base) a where
  encoding :: Around base -> Proxy a -> ByteString
encoding (Around PayloadProcessor
_ base
base) = base -> Proxy a -> ByteString
forall fmt a. Codec fmt a => fmt -> Proxy a -> ByteString
encoding base
base
  encode :: Around base -> a -> IO Payload
encode (Around PayloadProcessor
p base
base) a
x = base -> a -> IO Payload
forall fmt a. Codec fmt a => fmt -> a -> IO Payload
encode base
base a
x IO Payload -> (Payload -> IO Payload) -> IO Payload
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PayloadProcessor -> Payload -> IO Payload
payloadProcessorEncode PayloadProcessor
p
  decode :: Around base -> Payload -> IO (Either String a)
decode (Around PayloadProcessor
p base
base) Payload
x =
    PayloadProcessor -> Payload -> IO (Either String Payload)
payloadProcessorDecode PayloadProcessor
p Payload
x IO (Either String Payload)
-> (Either String Payload -> IO (Either String a))
-> IO (Either String a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left String
err -> Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
err
      Right Payload
x' -> base -> Payload -> IO (Either String a)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode base
base Payload
x'


type family ArgsAndResult' (f :: Type) (args :: [Type]) :: ([Type], Type) where
  ArgsAndResult' (arg -> rest) args = ArgsAndResult' rest (arg ': args)
  ArgsAndResult' result args = '(args, result)


type family ArgsAndResult (f :: Type) :: ([Type], Type) where
  ArgsAndResult f = ArgsAndResult' f '[]


type family ArgsOf f where
  ArgsOf (arg -> rest) = arg ': ArgsOf rest
  ArgsOf _ = '[]


type family FunctorInnerValue m :: Type -> Type where
  FunctorInnerValue (m a) = a


type family ResultOf (m :: Type -> Type) f where
  ResultOf m (_ -> rest) = ResultOf m rest
  ResultOf m (m result) = result
  ResultOf m result = TypeError ('Text "This function must use the (" ':<>: 'ShowType m ':<>: 'Text ") monad." ':$$: ('Text "Current type: " ':<>: 'ShowType result))


-- | Construct a function type from a list of argument types and a result type.
type family (:->:) (args :: [Type]) (result :: Type) where
  (:->:) '[] result = result
  (:->:) (arg ': args) result = arg -> (args :->: result)


infixr 0 :->:


-- | Applies a constraint to all types in a type-level list.
type family AllArgs (c :: Type -> Constraint) (args :: [Type]) :: Constraint where
  AllArgs _ '[] = ()
  AllArgs c (arg ': args) = (c arg, AllArgs c args)


class VarArgs (args :: [Type]) where
  sequenceArgs :: Monad m => Proxy (m result) -> m (args :->: m result) -> args :->: m result


  mapResult :: (result -> result') -> (args :->: result) -> (args :->: result')


  foldlArgs :: forall c b. (AllArgs c args) => Proxy c -> (forall a. c a => b -> a -> b) -> b -> (args :->: b)


-- Instance for the base case where there are no arguments left
instance VarArgs '[] where
  sequenceArgs :: Monad m => Proxy (m result) -> m (m result) -> m result
  sequenceArgs :: forall (m :: * -> *) result.
Monad m =>
Proxy (m result) -> m (m result) -> m result
sequenceArgs Proxy (m result)
_ = m (m result) -> m result
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
  {-# INLINE sequenceArgs #-}


  mapResult :: (result -> result') -> result -> result'
  mapResult :: forall result result'. (result -> result') -> result -> result'
mapResult result -> result'
f = result -> result'
f
  {-# INLINE mapResult #-}


  foldlArgs :: forall (c :: * -> Constraint) b.
AllArgs c '[] =>
Proxy c -> (forall a. c a => b -> a -> b) -> b -> '[] :->: b
foldlArgs Proxy c
_ forall a. c a => b -> a -> b
_ !b
x = b
'[] :->: b
x
  {-# INLINE foldlArgs #-}


-- Instance for the recursive case where there's at least one argument
instance (VarArgs args) => VarArgs (arg ': args) where
  sequenceArgs :: forall result (m :: Type -> Type). Monad m => Proxy (m result) -> m ((arg ': args) :->: m result) -> (arg -> (args :->: m result))
  sequenceArgs :: forall result (m :: * -> *).
Monad m =>
Proxy (m result)
-> m ((arg : args) :->: m result) -> arg -> args :->: m result
sequenceArgs Proxy (m result)
p m ((arg : args) :->: m result)
action arg
arg = forall (args :: [*]) (m :: * -> *) result.
(VarArgs args, Monad m) =>
Proxy (m result) -> m (args :->: m result) -> args :->: m result
sequenceArgs @args Proxy (m result)
p (m (args :->: m result) -> args :->: m result)
-> m (args :->: m result) -> args :->: m result
forall a b. (a -> b) -> a -> b
$ do
    f <- m ((arg : args) :->: m result)
action
    return (f arg)
  {-# INLINE sequenceArgs #-}


  mapResult :: forall result result'. (result -> result') -> (arg -> (args :->: result)) -> (arg -> (args :->: result'))
  mapResult :: forall result result'.
(result -> result')
-> (arg -> args :->: result) -> arg -> args :->: result'
mapResult result -> result'
f arg -> args :->: result
g arg
arg = forall (args :: [*]) result result'.
VarArgs args =>
(result -> result') -> (args :->: result) -> args :->: result'
mapResult @args @result result -> result'
f (arg -> args :->: result
g arg
arg)
  {-# INLINE mapResult #-}


  foldlArgs :: forall (c :: * -> Constraint) b.
AllArgs c (arg : args) =>
Proxy c
-> (forall a. c a => b -> a -> b) -> b -> (arg : args) :->: b
foldlArgs Proxy c
p forall a. c a => b -> a -> b
f !b
acc arg
arg = forall (args :: [*]) (c :: * -> Constraint) b.
(VarArgs args, AllArgs c args) =>
Proxy c -> (forall a. c a => b -> a -> b) -> b -> args :->: b
foldlArgs @args Proxy c
p b -> a -> b
forall a. c a => b -> a -> b
f (b -> arg -> b
forall a. c a => b -> a -> b
f b
acc arg
arg)
  {-# INLINE foldlArgs #-}


hoistResult :: forall args result m n. VarArgs args => (forall x. m x -> n x) -> (args :->: m result) -> (args :->: n result)
hoistResult :: forall {k} (args :: [*]) (result :: k) (m :: k -> *) (n :: k -> *).
VarArgs args =>
(forall (x :: k). m x -> n x)
-> (args :->: m result) -> args :->: n result
hoistResult = forall (args :: [*]) result result'.
VarArgs args =>
(result -> result') -> (args :->: result) -> args :->: result'
mapResult @args @(m result)
{-# INLINE hoistResult #-}


foldMapArgs :: forall args c m. (VarArgs args, AllArgs c args, Monoid m) => (forall a. c a => a -> m) -> args :->: m
foldMapArgs :: forall (args :: [*]) (c :: * -> Constraint) m.
(VarArgs args, AllArgs c args, Monoid m) =>
(forall a. c a => a -> m) -> args :->: m
foldMapArgs forall a. c a => a -> m
f = forall (args :: [*]) (c :: * -> Constraint) b.
(VarArgs args, AllArgs c args) =>
Proxy c -> (forall a. c a => b -> a -> b) -> b -> args :->: b
foldlArgs @args @c @m Proxy c
forall {k} (t :: k). Proxy t
Proxy (\m
acc a
a -> m
acc m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
forall a. c a => a -> m
f a
a) m
forall a. Monoid a => a
mempty
{-# INLINE foldMapArgs #-}


foldMArgs :: forall args c b m. (VarArgs args, AllArgs c args, Monad m) => (forall a. c a => b -> a -> m b) -> b -> args :->: m b
foldMArgs :: forall (args :: [*]) (c :: * -> Constraint) b (m :: * -> *).
(VarArgs args, AllArgs c args, Monad m) =>
(forall a. c a => b -> a -> m b) -> b -> args :->: m b
foldMArgs forall a. c a => b -> a -> m b
f b
x = forall (args :: [*]) (c :: * -> Constraint) b.
(VarArgs args, AllArgs c args) =>
Proxy c -> (forall a. c a => b -> a -> b) -> b -> args :->: b
foldlArgs @args @c @(m b) Proxy c
forall {k} (t :: k). Proxy t
Proxy (\m b
acc a
y -> m b
acc m b -> (b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(!b
x') -> b -> a -> m b
forall a. c a => b -> a -> m b
f b
x' a
y) (b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x)
{-# INLINE foldMArgs #-}


foldMArgs_ :: forall args c b m. (VarArgs args, AllArgs c args, Monad m) => (forall a. c a => b -> a -> m b) -> b -> args :->: m ()
foldMArgs_ :: forall (args :: [*]) (c :: * -> Constraint) b (m :: * -> *).
(VarArgs args, AllArgs c args, Monad m) =>
(forall a. c a => b -> a -> m b) -> b -> args :->: m ()
foldMArgs_ forall a. c a => b -> a -> m b
f b
x = forall (args :: [*]) result result'.
VarArgs args =>
(result -> result') -> (args :->: result) -> args :->: result'
mapResult @args @(m b) @(m ()) m b -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (args :: [*]) (c :: * -> Constraint) b (m :: * -> *).
(VarArgs args, AllArgs c args, Monad m) =>
(forall a. c a => b -> a -> m b) -> b -> args :->: m b
foldMArgs @args @c @b @m b -> a -> m b
forall a. c a => b -> a -> m b
f b
x)
{-# INLINE foldMArgs_ #-}


type UnencodedPayload = IO Payload


{- | This is the final step in the process of encoding payloads.

It takes a list of suspended payload encodings and runs them through the payload processor.
This allows us to
-}
processorEncodePayloads :: (MonadIO m, Traversable f) => PayloadProcessor -> f Payload -> m (f Payload)
processorEncodePayloads :: forall (m :: * -> *) (f :: * -> *).
(MonadIO m, Traversable f) =>
PayloadProcessor -> f Payload -> m (f Payload)
processorEncodePayloads PayloadProcessor
processor = IO (f Payload) -> m (f Payload)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (f Payload) -> m (f Payload))
-> (f Payload -> IO (f Payload)) -> f Payload -> m (f Payload)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Payload -> IO Payload) -> f Payload -> IO (f Payload)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f b)
mapM (PayloadProcessor -> Payload -> IO Payload
payloadProcessorEncode PayloadProcessor
processor)
{-# INLINE processorEncodePayloads #-}


processorDecodePayloads :: (MonadIO m, Traversable f) => PayloadProcessor -> f Payload -> m (f Payload)
processorDecodePayloads :: forall (m :: * -> *) (f :: * -> *).
(MonadIO m, Traversable f) =>
PayloadProcessor -> f Payload -> m (f Payload)
processorDecodePayloads PayloadProcessor
processor = IO (f Payload) -> m (f Payload)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (f Payload) -> m (f Payload))
-> (f Payload -> IO (f Payload)) -> f Payload -> m (f Payload)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Payload -> IO Payload) -> f Payload -> IO (f Payload)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f b)
mapM (PayloadProcessor -> Payload -> IO (Either String Payload)
payloadProcessorDecode PayloadProcessor
processor (Payload -> IO (Either String Payload))
-> (Either String Payload -> IO Payload) -> Payload -> IO Payload
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (String -> IO Payload)
-> (Payload -> IO Payload) -> Either String Payload -> IO Payload
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ValueError -> IO Payload
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ValueError -> IO Payload)
-> (String -> ValueError) -> String -> IO Payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ValueError
ValueError) Payload -> IO Payload
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE processorDecodePayloads #-}


gatherArgs :: forall args codec. (VarArgs args, AllArgs (Codec codec) args) => codec -> args :->: V.Vector UnencodedPayload
gatherArgs :: forall (args :: [*]) codec.
(VarArgs args, AllArgs (Codec codec) args) =>
codec -> args :->: Vector (IO Payload)
gatherArgs codec
codec = forall (args :: [*]) result result'.
VarArgs args =>
(result -> result') -> (args :->: result) -> args :->: result'
mapResult @args @(B.Bundle V.Vector UnencodedPayload) @(V.Vector UnencodedPayload) Bundle Vector (IO Payload) -> Vector (IO Payload)
forall (v :: * -> *) a. Vector v a => Bundle v a -> v a
VG.unstream (forall (args :: [*]) (c :: * -> Constraint) b.
(VarArgs args, AllArgs c args) =>
Proxy c -> (forall a. c a => b -> a -> b) -> b -> args :->: b
foldlArgs @args @(Codec codec) Proxy (Codec codec)
forall {k} (t :: k). Proxy t
Proxy Bundle Vector (IO Payload) -> a -> Bundle Vector (IO Payload)
forall a.
Codec codec a =>
Bundle Vector (IO Payload) -> a -> Bundle Vector (IO Payload)
go Bundle Vector (IO Payload)
forall (v :: * -> *) a. Bundle v a
B.empty)
  where
    go :: forall a. Codec codec a => B.Bundle V.Vector UnencodedPayload -> a -> B.Bundle V.Vector UnencodedPayload
    go :: forall a.
Codec codec a =>
Bundle Vector (IO Payload) -> a -> Bundle Vector (IO Payload)
go Bundle Vector (IO Payload)
acc a
arg = Bundle Vector (IO Payload)
-> IO Payload -> Bundle Vector (IO Payload)
forall (v :: * -> *) a. Bundle v a -> a -> Bundle v a
B.snoc Bundle Vector (IO Payload)
acc (codec -> a -> IO Payload
forall fmt a. Codec fmt a => fmt -> a -> IO Payload
encode codec
codec a
arg)
{-# INLINE gatherArgs #-}


withArgs :: forall args result codec. (VarArgs args, AllArgs (Codec codec) args) => codec -> (V.Vector UnencodedPayload -> result) -> args :->: result
withArgs :: forall (args :: [*]) result codec.
(VarArgs args, AllArgs (Codec codec) args) =>
codec -> (Vector (IO Payload) -> result) -> args :->: result
withArgs codec
codec Vector (IO Payload) -> result
f = forall (args :: [*]) result result'.
VarArgs args =>
(result -> result') -> (args :->: result) -> args :->: result'
mapResult @args @(V.Vector UnencodedPayload) @result Vector (IO Payload) -> result
f (forall (args :: [*]) codec.
(VarArgs args, AllArgs (Codec codec) args) =>
codec -> args :->: Vector (IO Payload)
gatherArgs @args @codec codec
codec)
{-# INLINE withArgs #-}


data Payload = Payload
  { Payload -> ByteString
payloadData :: ByteString
  , Payload -> Map Text ByteString
payloadMetadata :: Data.Map.Strict.Map Text ByteString
  }
  deriving stock (Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> String
(Int -> Payload -> ShowS)
-> (Payload -> String) -> ([Payload] -> ShowS) -> Show Payload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Payload -> ShowS
showsPrec :: Int -> Payload -> ShowS
$cshow :: Payload -> String
show :: Payload -> String
$cshowList :: [Payload] -> ShowS
showList :: [Payload] -> ShowS
Show, Payload -> Payload -> Bool
(Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool) -> Eq Payload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
/= :: Payload -> Payload -> Bool
Eq, Eq Payload
Eq Payload =>
(Payload -> Payload -> Ordering)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Payload)
-> (Payload -> Payload -> Payload)
-> Ord Payload
Payload -> Payload -> Bool
Payload -> Payload -> Ordering
Payload -> Payload -> Payload
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 :: Payload -> Payload -> Ordering
compare :: Payload -> Payload -> Ordering
$c< :: Payload -> Payload -> Bool
< :: Payload -> Payload -> Bool
$c<= :: Payload -> Payload -> Bool
<= :: Payload -> Payload -> Bool
$c> :: Payload -> Payload -> Bool
> :: Payload -> Payload -> Bool
$c>= :: Payload -> Payload -> Bool
>= :: Payload -> Payload -> Bool
$cmax :: Payload -> Payload -> Payload
max :: Payload -> Payload -> Payload
$cmin :: Payload -> Payload -> Payload
min :: Payload -> Payload -> Payload
Ord, (forall (m :: * -> *). Quote m => Payload -> m Exp)
-> (forall (m :: * -> *). Quote m => Payload -> Code m Payload)
-> Lift Payload
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Payload -> m Exp
forall (m :: * -> *). Quote m => Payload -> Code m Payload
$clift :: forall (m :: * -> *). Quote m => Payload -> m Exp
lift :: forall (m :: * -> *). Quote m => Payload -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Payload -> Code m Payload
liftTyped :: forall (m :: * -> *). Quote m => Payload -> Code m Payload
Lift)


base64DecodeFromText :: MonadFail m => T.Text -> m ByteString
base64DecodeFromText :: forall (m :: * -> *). MonadFail m => Text -> m ByteString
base64DecodeFromText Text
txt = case ByteString -> Either Text ByteString
decodeBase64 (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
txt of
  Left Text
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
err
  Right ByteString
ok -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
ok


instance FromJSON Payload where
  parseJSON :: Value -> Parser Payload
parseJSON = String -> (Object -> Parser Payload) -> Value -> Parser Payload
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Payload" ((Object -> Parser Payload) -> Value -> Parser Payload)
-> (Object -> Parser Payload) -> Value -> Parser Payload
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    rawPayloadData <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"
    rawPayloadMetadata <- o .:? "metadata"
    payloadData <- maybe (pure mempty) base64DecodeFromText rawPayloadData
    payloadMetadata <- maybe (pure mempty) (traverse base64DecodeFromText) rawPayloadMetadata
    pure Payload {..}


instance ToJSON Payload where
  toJSON :: Payload -> Value
toJSON Payload {ByteString
Map Text ByteString
payloadData :: Payload -> ByteString
payloadMetadata :: Payload -> Map Text ByteString
payloadData :: ByteString
payloadMetadata :: Map Text ByteString
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      (if ByteString
payloadData ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then [Pair] -> [Pair]
forall a. a -> a
id else ((Key
"data" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
encodeBase64 ByteString
payloadData) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
:)) ([Pair] -> [Pair]) -> [Pair] -> [Pair]
forall a b. (a -> b) -> a -> b
$
        (if Map Text ByteString -> Bool
forall k a. Map k a -> Bool
Map.null Map Text ByteString
payloadMetadata then [Pair] -> [Pair]
forall a. a -> a
id else ((Key
"metadata" Key -> Map Text Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text) -> Map Text ByteString -> Map Text Text
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
encodeBase64 Map Text ByteString
payloadMetadata) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
:))
          []
  toEncoding :: Payload -> Encoding
toEncoding Payload {ByteString
Map Text ByteString
payloadData :: Payload -> ByteString
payloadMetadata :: Payload -> Map Text ByteString
payloadData :: ByteString
payloadMetadata :: Map Text ByteString
..} =
    Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
      (if ByteString
payloadData ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then Series
forall a. Monoid a => a
mempty else Key
"data" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
encodeBase64 ByteString
payloadData)
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (if Map Text ByteString -> Bool
forall k a. Map k a -> Bool
Map.null Map Text ByteString
payloadMetadata then Series
forall a. Monoid a => a
mempty else Key
"metadata" Key -> Map Text Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text) -> Map Text ByteString -> Map Text Text
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
encodeBase64 Map Text ByteString
payloadMetadata)


convertFromProtoPayload :: Proto.Payload -> Payload
convertFromProtoPayload :: Payload -> Payload
convertFromProtoPayload Payload
p = ByteString -> Map Text ByteString -> Payload
Payload (Payload
p Payload
-> FoldLike ByteString Payload Payload ByteString ByteString
-> ByteString
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike ByteString Payload Payload ByteString ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "data'" a) =>
LensLike' f s a
Proto.data') (Payload
p Payload
-> FoldLike
     (Map Text ByteString)
     Payload
     Payload
     (Map Text ByteString)
     (Map Text ByteString)
-> Map Text ByteString
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  (Map Text ByteString)
  Payload
  Payload
  (Map Text ByteString)
  (Map Text ByteString)
forall (f :: * -> *) s a.
(Functor f, HasField s "metadata" a) =>
LensLike' f s a
Proto.metadata)


convertToProtoPayload :: Payload -> Proto.Payload
convertToProtoPayload :: Payload -> Payload
convertToProtoPayload (Payload ByteString
d Map Text ByteString
m) =
  Payload
forall msg. Message msg => msg
defMessage
    Payload -> (Payload -> Payload) -> Payload
forall s t. s -> (s -> t) -> t
& LensLike' f Payload ByteString
forall {f :: * -> *}. Identical f => LensLike' f Payload ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "data'" a) =>
LensLike' f s a
Proto.data' (forall {f :: * -> *}.
 Identical f =>
 LensLike' f Payload ByteString)
-> ByteString -> Payload -> Payload
forall s t a b. Setter s t a b -> b -> s -> t
.~ ByteString
d
    Payload -> (Payload -> Payload) -> Payload
forall s t. s -> (s -> t) -> t
& LensLike' f Payload (Map Text ByteString)
forall {f :: * -> *}.
Identical f =>
LensLike' f Payload (Map Text ByteString)
forall (f :: * -> *) s a.
(Functor f, HasField s "metadata" a) =>
LensLike' f s a
Proto.metadata (forall {f :: * -> *}.
 Identical f =>
 LensLike' f Payload (Map Text ByteString))
-> Map Text ByteString -> Payload -> Payload
forall s t a b. Setter s t a b -> b -> s -> t
.~ Map Text ByteString
m


class ApplyPayloads codec (args :: [Type]) where
  applyPayloads
    :: codec
    -> Proxy args
    -> Proxy result
    -> (args :->: result)
    -> V.Vector Payload
    -> IO (Either String result)


instance ApplyPayloads codec '[] where
  applyPayloads :: forall result.
codec
-> Proxy '[]
-> Proxy result
-> ('[] :->: result)
-> Vector Payload
-> IO (Either String result)
applyPayloads codec
_ Proxy '[]
_ Proxy result
_ '[] :->: result
f Vector Payload
_ = Either String result -> IO (Either String result)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String result -> IO (Either String result))
-> Either String result -> IO (Either String result)
forall a b. (a -> b) -> a -> b
$ ('[] :->: result) -> Either String ('[] :->: result)
forall a b. b -> Either a b
Right '[] :->: result
f


instance (Codec codec ty, ApplyPayloads codec tys) => ApplyPayloads codec (ty ': tys) where
  applyPayloads :: forall result.
codec
-> Proxy (ty : tys)
-> Proxy result
-> ((ty : tys) :->: result)
-> Vector Payload
-> IO (Either String result)
applyPayloads codec
codec Proxy (ty : tys)
_ Proxy result
resP (ty : tys) :->: result
f Vector Payload
vec = case Vector Payload -> Maybe (Payload, Vector Payload)
forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Payload
vec of
    Maybe (Payload, Vector Payload)
Nothing -> Either String result -> IO (Either String result)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String result -> IO (Either String result))
-> Either String result -> IO (Either String result)
forall a b. (a -> b) -> a -> b
$ String -> Either String result
forall a b. a -> Either a b
Left String
"Not enough arguments"
    Just (Payload
pl, Vector Payload
rest) -> do
      res <- codec -> Payload -> IO (Either String ty)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode codec
codec Payload
pl
      case res of
        Right ty
arg -> codec
-> Proxy tys
-> Proxy result
-> (tys :->: result)
-> Vector Payload
-> IO (Either String result)
forall result.
codec
-> Proxy tys
-> Proxy result
-> (tys :->: result)
-> Vector Payload
-> IO (Either String result)
forall codec (args :: [*]) result.
ApplyPayloads codec args =>
codec
-> Proxy args
-> Proxy result
-> (args :->: result)
-> Vector Payload
-> IO (Either String result)
applyPayloads codec
codec (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @tys) Proxy result
resP ((ty : tys) :->: result
ty -> tys :->: result
f ty
arg) Vector Payload
rest
        Left String
err -> Either String result -> IO (Either String result)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String result -> IO (Either String result))
-> Either String result -> IO (Either String result)
forall a b. (a -> b) -> a -> b
$ String -> Either String result
forall a b. a -> Either a b
Left String
err


type GatherArgs codec args = (VarArgs args, AllArgs (Codec codec) args)


type GatherArgsOf codec f = GatherArgs codec (ArgsOf f)


type FunctionSupportsCodec codec args result = (GatherArgs codec args, Codec codec result, Typeable result, ApplyPayloads codec args)


type FunctionSupportsCodec' m codec f = (FunctionSupportsCodec codec (ArgsOf f) (ResultOf m f), f ~ (ArgsOf f :->: m (ResultOf m f)))