module Temporal.Codec.Server (
  codecServerMiddleware,
  CodecServerConfig (..),
  CorsResourcePolicy (..),
  ErrorResponse (..),
  AuthorizationHeaderValue,
  Payload (..),
  temporalCloudCorsPolicy,
) where

import Control.Monad.Trans.Except
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString as BS
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Vector (Vector)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Middleware.Cors
import Temporal.Payload
import Temporal.Workflow (Namespace (..))


data Body = Body
  { Body -> Vector Payload
payloads :: Vector Payload
  }


instance ToJSON Body where
  toJSON :: Body -> Value
toJSON (Body Vector Payload
payloads) = [Pair] -> Value
object [Key
"payloads" Key -> Vector Payload -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector Payload
payloads]
  toEncoding :: Body -> Encoding
toEncoding (Body Vector Payload
payloads) = Series -> Encoding
pairs (Key
"payloads" Key -> Vector Payload -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector Payload
payloads)


instance FromJSON Body where
  parseJSON :: Value -> Parser Body
parseJSON = String -> (Object -> Parser Body) -> Value -> Parser Body
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Body" ((Object -> Parser Body) -> Value -> Parser Body)
-> (Object -> Parser Body) -> Value -> Parser Body
forall a b. (a -> b) -> a -> b
$ \Object
o -> Vector Payload -> Body
Body (Vector Payload -> Body) -> Parser (Vector Payload) -> Parser Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Vector Payload)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"payloads"


type AuthorizationHeaderValue = BS.ByteString


data ErrorResponse = ErrorResponse
  { ErrorResponse -> Status
errorStatus :: Status
  , ErrorResponse -> String
errorMessage :: String
  }


data CodecServerConfig = CodecServerConfig
  { CodecServerConfig
-> Namespace
-> Maybe ByteString
-> Payload
-> ExceptT ErrorResponse IO Payload
codecServerDecoder :: !(Namespace -> Maybe AuthorizationHeaderValue -> Payload -> ExceptT ErrorResponse IO Payload)
  , CodecServerConfig
-> Namespace
-> Maybe ByteString
-> Payload
-> ExceptT ErrorResponse IO Payload
codecServerEncoder :: !(Namespace -> Maybe AuthorizationHeaderValue -> Payload -> ExceptT ErrorResponse IO Payload)
  , CodecServerConfig -> [Text]
endpointBase :: [Text]
  -- ^ Path segments
  , CodecServerConfig -> CorsResourcePolicy
corsPolicy :: CorsResourcePolicy
  }


errorResponse :: ErrorResponse -> Response
errorResponse :: ErrorResponse -> Response
errorResponse ErrorResponse
err = Status -> ResponseHeaders -> ByteString -> Response
responseLBS ErrorResponse
err.errorStatus ResponseHeaders
respHeaders (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ErrorResponse
err.errorMessage]


namespaceHeader :: HeaderName
namespaceHeader :: HeaderName
namespaceHeader = HeaderName
"x-namespace"


streamingDecode :: Request -> ExceptT ErrorResponse IO Body
streamingDecode :: Request -> ExceptT ErrorResponse IO Body
streamingDecode Request
req = IO (Either ErrorResponse Body) -> ExceptT ErrorResponse IO Body
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((String -> ErrorResponse)
-> Either String Body -> Either ErrorResponse Body
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 (Status -> String -> ErrorResponse
ErrorResponse Status
status500) (Either String Body -> Either ErrorResponse Body)
-> (ByteString -> Either String Body)
-> ByteString
-> Either ErrorResponse Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Body
forall a. FromJSON a => ByteString -> Either String a
eitherDecode' (ByteString -> Either ErrorResponse Body)
-> IO ByteString -> IO (Either ErrorResponse Body)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO ByteString
consumeRequestBodyLazy Request
req)


respHeaders :: ResponseHeaders
respHeaders :: ResponseHeaders
respHeaders =
  [ (HeaderName
hContentType, ByteString
"application/json; charset=utf-8")
  ]


requireNamespaceHeader :: Request -> ExceptT ErrorResponse IO Namespace
requireNamespaceHeader :: Request -> ExceptT ErrorResponse IO Namespace
requireNamespaceHeader Request
req = case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
namespaceHeader (Request -> ResponseHeaders
requestHeaders Request
req) of
  Maybe ByteString
Nothing -> IO (Either ErrorResponse Namespace)
-> ExceptT ErrorResponse IO Namespace
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorResponse Namespace)
 -> ExceptT ErrorResponse IO Namespace)
-> IO (Either ErrorResponse Namespace)
-> ExceptT ErrorResponse IO Namespace
forall a b. (a -> b) -> a -> b
$ Either ErrorResponse Namespace
-> IO (Either ErrorResponse Namespace)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorResponse Namespace
 -> IO (Either ErrorResponse Namespace))
-> Either ErrorResponse Namespace
-> IO (Either ErrorResponse Namespace)
forall a b. (a -> b) -> a -> b
$ ErrorResponse -> Either ErrorResponse Namespace
forall a b. a -> Either a b
Left (ErrorResponse -> Either ErrorResponse Namespace)
-> ErrorResponse -> Either ErrorResponse Namespace
forall a b. (a -> b) -> a -> b
$ Status -> String -> ErrorResponse
ErrorResponse Status
status500 String
"Missing required x-namespace header"
  Just ByteString
ns -> Namespace -> ExceptT ErrorResponse IO Namespace
forall a. a -> ExceptT ErrorResponse IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace -> ExceptT ErrorResponse IO Namespace)
-> Namespace -> ExceptT ErrorResponse IO Namespace
forall a b. (a -> b) -> a -> b
$ Text -> Namespace
Namespace (Text -> Namespace) -> Text -> Namespace
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 ByteString
ns


temporalCloudCorsPolicy :: CorsResourcePolicy
temporalCloudCorsPolicy :: CorsResourcePolicy
temporalCloudCorsPolicy =
  CorsResourcePolicy
simpleCorsResourcePolicy
    { corsOrigins = Just (["https://cloud.temporal.io"], True)
    , corsMethods = [methodGet, methodPost, methodOptions]
    , corsRequestHeaders = [namespaceHeader, hContentType, hAuthorization]
    , corsRequireOrigin = True
    , corsIgnoreFailures = True
    }


codecServerMiddleware
  :: CodecServerConfig
  -> Middleware
codecServerMiddleware :: CodecServerConfig -> Middleware
codecServerMiddleware CodecServerConfig {[Text]
CorsResourcePolicy
Namespace
-> Maybe ByteString -> Payload -> ExceptT ErrorResponse IO Payload
codecServerDecoder :: CodecServerConfig
-> Namespace
-> Maybe ByteString
-> Payload
-> ExceptT ErrorResponse IO Payload
codecServerEncoder :: CodecServerConfig
-> Namespace
-> Maybe ByteString
-> Payload
-> ExceptT ErrorResponse IO Payload
endpointBase :: CodecServerConfig -> [Text]
corsPolicy :: CodecServerConfig -> CorsResourcePolicy
codecServerDecoder :: Namespace
-> Maybe ByteString -> Payload -> ExceptT ErrorResponse IO Payload
codecServerEncoder :: Namespace
-> Maybe ByteString -> Payload -> ExceptT ErrorResponse IO Payload
endpointBase :: [Text]
corsPolicy :: CorsResourcePolicy
..} =
  (Request -> Maybe CorsResourcePolicy) -> Middleware
cors (\Request
req -> if Request -> Bool
isCodecServerEndpoint Request
req then CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
corsPolicy else Maybe CorsResourcePolicy
forall a. Maybe a
Nothing)
    Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
baseMiddleware
  where
    baseMiddleware :: Middleware
baseMiddleware Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
app Request
req Response -> IO ResponseReceived
respond =
      let dispatch :: IO ResponseReceived
dispatch
            | Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
codecServerEncodeEndpoint = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
runEncode Request
req Response -> IO ResponseReceived
respond
            | Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
codecServerDecodeEndpoint = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
runDecode Request
req Response -> IO ResponseReceived
respond
            | Bool
otherwise = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
app Request
req Response -> IO ResponseReceived
respond
      in IO ResponseReceived
dispatch

    codecServerEncodeEndpoint :: [Text]
codecServerEncodeEndpoint = [Text]
endpointBase [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"encode"]
    codecServerDecodeEndpoint :: [Text]
codecServerDecodeEndpoint = [Text]
endpointBase [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"decode"]
    isCodecServerEndpoint :: Request -> Bool
isCodecServerEndpoint Request
req = Request -> [Text]
pathInfo Request
req [Text] -> [[Text]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Text]
codecServerEncodeEndpoint, [Text]
codecServerDecodeEndpoint]

    runEncode :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
runEncode Request
req Response -> IO ResponseReceived
respond = do
      let authHeader :: Maybe ByteString
authHeader = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAuthorization (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
      if Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
methodPost
        then Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
"{}"
        else do
          res <- ExceptT ErrorResponse IO (Vector Payload)
-> IO (Either ErrorResponse (Vector Payload))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorResponse IO (Vector Payload)
 -> IO (Either ErrorResponse (Vector Payload)))
-> ExceptT ErrorResponse IO (Vector Payload)
-> IO (Either ErrorResponse (Vector Payload))
forall a b. (a -> b) -> a -> b
$ do
            ns <- Request -> ExceptT ErrorResponse IO Namespace
requireNamespaceHeader Request
req
            body <- streamingDecode req
            traverse (codecServerEncoder ns authHeader) $ payloads body
          respond $ case res of
            Left ErrorResponse
err -> ErrorResponse -> Response
errorResponse ErrorResponse
err
            Right Vector Payload
ok -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
respHeaders (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Body -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode (Body -> ByteString) -> Body -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Payload -> Body
Body Vector Payload
ok

    runDecode :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
runDecode Request
req Response -> IO ResponseReceived
respond = do
      let authHeader :: Maybe ByteString
authHeader = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAuthorization (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
      if Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
methodPost
        then Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
"{}"
        else do
          res <- ExceptT ErrorResponse IO (Vector Payload)
-> IO (Either ErrorResponse (Vector Payload))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorResponse IO (Vector Payload)
 -> IO (Either ErrorResponse (Vector Payload)))
-> ExceptT ErrorResponse IO (Vector Payload)
-> IO (Either ErrorResponse (Vector Payload))
forall a b. (a -> b) -> a -> b
$ do
            ns <- Request -> ExceptT ErrorResponse IO Namespace
requireNamespaceHeader Request
req
            body <- streamingDecode req
            traverse (codecServerDecoder ns authHeader) $ payloads body
          respond $ case res of
            Left ErrorResponse
err -> ErrorResponse -> Response
errorResponse ErrorResponse
err
            Right Vector Payload
ok -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
respHeaders (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Body -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode (Body -> ByteString) -> Body -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Payload -> Body
Body Vector Payload
ok