{-|
Module      : AWS.Lambda.RuntimeClient
Description : HTTP related machinery for talking to the AWS Lambda Custom Runtime interface.
Copyright   : (c) Nike, Inc., 2018
License     : BSD3
Maintainer  : nathan.fairhurst@nike.com, fernando.freire@nike.com
Stability   : stable
-}

module AWS.Lambda.RuntimeClient (
  RuntimeClientConfig,
  getRuntimeClientConfig,
  getNextData,
  getNextEvent,
  sendEventSuccess,
  sendEventError,
) where

import           AWS.Lambda.Context        (LambdaContext(..))
import           AWS.Lambda.Internal       (DynamicContext(..), StaticContext,
                                            mkContext)
import           Control.Applicative       ((<*>))
import           Control.Concurrent        (threadDelay)
import           Control.Exception         (displayException, try, throw)
import           Control.Monad             (unless)
import           Control.Monad.IO.Class    (MonadIO, liftIO)
import           Data.Aeson                (decode, encode, Value)
import           Data.Aeson.Parser         (value')
import           Data.Aeson.Types          (FromJSON, ToJSON)
import           Data.Bifunctor            (first)
import qualified Data.ByteString           as BS
import qualified Data.ByteString.Char8     as BSC
import qualified Data.ByteString.Lazy      as BSW
import qualified Data.ByteString.Internal  as BSI
import           Data.Conduit              (ConduitM, runConduit, yield, (.|))
import           Data.Conduit.Attoparsec   (sinkParser)
import           Data.Text.Encoding        (decodeUtf8)
import           Data.Time.Clock.POSIX     (posixSecondsToUTCTime)
import           GHC.Generics              (Generic (..))
import           Network.HTTP.Client       (BodyReader, HttpException, Manager,
                                            Request, Response, brRead,
                                            defaultManagerSettings, httpNoBody,
                                            managerConnCount,
                                            managerIdleConnectionCount,
                                            managerResponseTimeout,
                                            managerSetProxy, newManager,
                                            noProxy, parseRequest, responseBody,
                                            responseTimeoutNone, withResponse)
import           Network.HTTP.Simple       (getResponseBody,
                                            getResponseHeader,
                                            getResponseStatus,
                                            setRequestBodyJSON,
                                            setRequestBodyLBS,
                                            setRequestCheckStatus,
                                            setRequestHeader, setRequestMethod,
                                            setRequestPath)
import           Network.HTTP.Types.Status (status403, status413, statusIsSuccessful)
import           System.Environment        (getEnv)
import           System.Envy               (decodeEnv)

-- | Lambda runtime error that we pass back to AWS
data LambdaError = LambdaError
  { LambdaError -> String
errorMessage :: String,
    LambdaError -> String
errorType    :: String,
    LambdaError -> [String]
stackTrace   :: [String]
  } deriving (Int -> LambdaError -> ShowS
[LambdaError] -> ShowS
LambdaError -> String
(Int -> LambdaError -> ShowS)
-> (LambdaError -> String)
-> ([LambdaError] -> ShowS)
-> Show LambdaError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LambdaError] -> ShowS
$cshowList :: [LambdaError] -> ShowS
show :: LambdaError -> String
$cshow :: LambdaError -> String
showsPrec :: Int -> LambdaError -> ShowS
$cshowsPrec :: Int -> LambdaError -> ShowS
Show, (forall x. LambdaError -> Rep LambdaError x)
-> (forall x. Rep LambdaError x -> LambdaError)
-> Generic LambdaError
forall x. Rep LambdaError x -> LambdaError
forall x. LambdaError -> Rep LambdaError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LambdaError x -> LambdaError
$cfrom :: forall x. LambdaError -> Rep LambdaError x
Generic)

instance ToJSON LambdaError

data RuntimeClientConfig = RuntimeClientConfig Request Manager StaticContext

-- Exposed Handlers

-- TODO: It would be interesting if we could make the interface a sort of
-- "chained" callback API.  So instead of getting back a base request to kick
-- things off we get a 'getNextEvent' handler and then the 'getNextEvent'
-- handler returns both the 'success' and 'error' handlers.  So things like
-- baseRequest and reqId are pre-injected.
getRuntimeClientConfig :: IO RuntimeClientConfig
getRuntimeClientConfig :: IO RuntimeClientConfig
getRuntimeClientConfig = do
  String
awsLambdaRuntimeApi <- String -> IO String
getEnv String
"AWS_LAMBDA_RUNTIME_API"
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
awsLambdaRuntimeApi
  Manager
man <- ManagerSettings -> IO Manager
newManager
           -- In the off chance that they set a proxy value, we don't want to
           -- use it.  There's also no reason to spend time reading env vars.
           (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetProxy ProxyOverride
noProxy
           (ManagerSettings -> ManagerSettings)
-> ManagerSettings -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ManagerSettings
defaultManagerSettings
             -- This is the most important setting, we must not timeout requests
             { managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = ResponseTimeout
responseTimeoutNone
             -- We only ever need a single connection, because we'll never make
             -- concurrent requests and never talk to more than one host.
             , managerConnCount :: Int
managerConnCount = Int
1
             , managerIdleConnectionCount :: Int
managerIdleConnectionCount = Int
1
             }

  Either String StaticContext
possibleStaticCtx <- IO (Either String StaticContext)
-> IO (Either String StaticContext)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String StaticContext)
 -> IO (Either String StaticContext))
-> IO (Either String StaticContext)
-> IO (Either String StaticContext)
forall a b. (a -> b) -> a -> b
$ (IO (Either String StaticContext)
forall a. FromEnv a => IO (Either String a)
decodeEnv :: IO (Either String StaticContext))

  case Either String StaticContext
possibleStaticCtx of
    Left String
err -> do
      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> String -> IO ()
sendInitError Request
req Manager
man String
err
      String -> IO RuntimeClientConfig
forall a. HasCallStack => String -> a
error String
err
    Right StaticContext
staticCtx -> RuntimeClientConfig -> IO RuntimeClientConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (RuntimeClientConfig -> IO RuntimeClientConfig)
-> RuntimeClientConfig -> IO RuntimeClientConfig
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> StaticContext -> RuntimeClientConfig
RuntimeClientConfig Request
req Manager
man StaticContext
staticCtx


getNextData :: RuntimeClientConfig -> IO (BS.ByteString, Value, Either String LambdaContext)
getNextData :: RuntimeClientConfig
-> IO (ByteString, Value, Either String LambdaContext)
getNextData runtimeClientConfig :: RuntimeClientConfig
runtimeClientConfig@(RuntimeClientConfig Request
_ Manager
_ StaticContext
staticContext) = do
  Response Value
nextRes <- RuntimeClientConfig -> IO (Response Value)
getNextEvent RuntimeClientConfig
runtimeClientConfig

  -- If we got an event but our requestId is invalid/missing, there's no hope of meaningful recovery
  let reqIdBS :: ByteString
reqIdBS = [ByteString] -> ByteString
forall a. [a] -> a
head ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Aws-Request-Id" Response Value
nextRes

  let mTraceId :: Maybe Text
mTraceId = (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (Maybe ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
exactlyOneHeader ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Trace-Id" Response Value
nextRes
  let mFunctionArn :: Maybe Text
mFunctionArn = (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (Maybe ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
exactlyOneHeader ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Invoked-Function-Arn" Response Value
nextRes
  let mDeadline :: Maybe UTCTime
mDeadline = do
        ByteString
header <- [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
exactlyOneHeader (HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Deadline-Ms" Response Value
nextRes)
        Double
milliseconds :: Double <- String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Double) -> String -> Maybe Double
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC.unpack ByteString
header
        UTCTime -> Maybe UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Double -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> POSIXTime) -> Double -> POSIXTime
forall a b. (a -> b) -> a -> b
$ Double
milliseconds Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000

  let mClientContext :: Maybe (Maybe ClientContext)
mClientContext = [ByteString] -> Maybe (Maybe ClientContext)
forall a. FromJSON a => [ByteString] -> Maybe (Maybe a)
decodeOptionalHeader ([ByteString] -> Maybe (Maybe ClientContext))
-> [ByteString] -> Maybe (Maybe ClientContext)
forall a b. (a -> b) -> a -> b
$ HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Client-Context" Response Value
nextRes
  let mIdentity :: Maybe (Maybe CognitoIdentity)
mIdentity = [ByteString] -> Maybe (Maybe CognitoIdentity)
forall a. FromJSON a => [ByteString] -> Maybe (Maybe a)
decodeOptionalHeader ([ByteString] -> Maybe (Maybe CognitoIdentity))
-> [ByteString] -> Maybe (Maybe CognitoIdentity)
forall a b. (a -> b) -> a -> b
$ HeaderName -> Response Value -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"Lambda-Runtime-Cognito-Identity" Response Value
nextRes

  -- Build out the Dynamic portion of the Lambda Context
  let eDynCtx :: Either String DynamicContext
eDynCtx =
        String -> Maybe DynamicContext -> Either String DynamicContext
forall b a. b -> Maybe a -> Either b a
maybeToEither String
"Runtime Error: Unable to decode Context from event response."
        -- Build the Dynamic Context, collapsing individual Maybes into a single Maybe
        (Maybe DynamicContext -> Either String DynamicContext)
-> Maybe DynamicContext -> Either String DynamicContext
forall a b. (a -> b) -> a -> b
$ Text
-> Text
-> Text
-> UTCTime
-> Maybe ClientContext
-> Maybe CognitoIdentity
-> DynamicContext
DynamicContext (ByteString -> Text
decodeUtf8 ByteString
reqIdBS)
        (Text
 -> Text
 -> UTCTime
 -> Maybe ClientContext
 -> Maybe CognitoIdentity
 -> DynamicContext)
-> Maybe Text
-> Maybe
     (Text
      -> UTCTime
      -> Maybe ClientContext
      -> Maybe CognitoIdentity
      -> DynamicContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mFunctionArn
        Maybe
  (Text
   -> UTCTime
   -> Maybe ClientContext
   -> Maybe CognitoIdentity
   -> DynamicContext)
-> Maybe Text
-> Maybe
     (UTCTime
      -> Maybe ClientContext -> Maybe CognitoIdentity -> DynamicContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
mTraceId
        Maybe
  (UTCTime
   -> Maybe ClientContext -> Maybe CognitoIdentity -> DynamicContext)
-> Maybe UTCTime
-> Maybe
     (Maybe ClientContext -> Maybe CognitoIdentity -> DynamicContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mDeadline
        Maybe
  (Maybe ClientContext -> Maybe CognitoIdentity -> DynamicContext)
-> Maybe (Maybe ClientContext)
-> Maybe (Maybe CognitoIdentity -> DynamicContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe ClientContext)
mClientContext
        Maybe (Maybe CognitoIdentity -> DynamicContext)
-> Maybe (Maybe CognitoIdentity) -> Maybe DynamicContext
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe CognitoIdentity)
mIdentity

  -- combine our StaticContext and possible DynamicContext into a LambdaContext
  let eCtx :: Either String LambdaContext
eCtx = (DynamicContext -> LambdaContext)
-> Either String DynamicContext -> Either String LambdaContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StaticContext -> DynamicContext -> LambdaContext
mkContext StaticContext
staticContext) Either String DynamicContext
eDynCtx

  let event :: Value
event = Response Value -> Value
forall a. Response a -> a
getResponseBody Response Value
nextRes

  -- Return the interesting components
  (ByteString, Value, Either String LambdaContext)
-> IO (ByteString, Value, Either String LambdaContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
reqIdBS, Value
event, Either String LambdaContext
eCtx)

-- AWS lambda guarantees that we will get valid JSON,
-- so parsing is guaranteed to succeed.
getNextEvent :: RuntimeClientConfig -> IO (Response Value)
getNextEvent :: RuntimeClientConfig -> IO (Response Value)
getNextEvent (RuntimeClientConfig Request
baseRuntimeRequest Manager
manager StaticContext
_) = do
  Either HttpException (Response Value)
resOrEx <- IO (Response Value) -> IO (Either HttpException (Response Value))
forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry (IO (Response Value) -> IO (Either HttpException (Response Value)))
-> IO (Response Value)
-> IO (Either HttpException (Response Value))
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response Value))
-> Manager -> Request -> IO (Response Value)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response Value)
httpValue Manager
manager (Request -> IO (Response Value)) -> Request -> IO (Response Value)
forall a b. (a -> b) -> a -> b
$ Request -> Request
toNextEventRequest Request
baseRuntimeRequest
  let checkStatus :: Response a -> Either a (Response a)
checkStatus Response a
res = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsSuccessful (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response a -> Status
forall a. Response a -> Status
getResponseStatus Response a
res then
        a -> Either a (Response a)
forall a b. a -> Either a b
Left a
"Unexpected Runtime Error:  Could not retrieve next event."
      else
        Response a -> Either a (Response a)
forall a b. b -> Either a b
Right Response a
res
  let resOrMsg :: Either String (Response Value)
resOrMsg = (HttpException -> String)
-> Either HttpException (Response Value)
-> Either String (Response Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (HttpException -> String
forall e. Exception e => e -> String
displayException :: HttpException -> String) Either HttpException (Response Value)
resOrEx Either String (Response Value)
-> (Response Value -> Either String (Response Value))
-> Either String (Response Value)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response Value -> Either String (Response Value)
forall a a. IsString a => Response a -> Either a (Response a)
checkStatus
  case Either String (Response Value)
resOrMsg of
    Left String
msg -> do
      ()
_ <- Request -> Manager -> String -> IO ()
sendInitError Request
baseRuntimeRequest Manager
manager String
msg
      String -> IO (Response Value)
forall a. HasCallStack => String -> a
error String
msg
    Right Response Value
y -> Response Value -> IO (Response Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Response Value
y

sendEventSuccess :: ToJSON a => RuntimeClientConfig -> BS.ByteString -> a -> IO ()
sendEventSuccess :: RuntimeClientConfig -> ByteString -> a -> IO ()
sendEventSuccess rcc :: RuntimeClientConfig
rcc@(RuntimeClientConfig Request
baseRuntimeRequest Manager
manager StaticContext
_) ByteString
reqId a
json = do
  Either HttpException (Response ())
resOrEx <- IO (Response ()) -> IO (Either HttpException (Response ()))
forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry (IO (Response ()) -> IO (Either HttpException (Response ())))
-> IO (Response ()) -> IO (Either HttpException (Response ()))
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response ()))
-> Manager -> Request -> IO (Response ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager (Request -> IO (Response ())) -> Request -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ ByteString -> a -> Request -> Request
forall a. ToJSON a => ByteString -> a -> Request -> Request
toEventSuccessRequest ByteString
reqId a
json Request
baseRuntimeRequest

  let resOrTypedMsg :: Either (Either String String) ()
resOrTypedMsg = case Either HttpException (Response ())
resOrEx of
        Left HttpException
ex ->
          -- aka NonRecoverable
          Either String String -> Either (Either String String) ()
forall a b. a -> Either a b
Left (Either String String -> Either (Either String String) ())
-> Either String String -> Either (Either String String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall e. Exception e => e -> String
displayException (HttpException
ex :: HttpException)
        Right Response ()
res ->
          if Response () -> Status
forall a. Response a -> Status
getResponseStatus Response ()
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status413 then
            -- TODO Get the real error info from the response
            -- aka Recoverable
            Either String String -> Either (Either String String) ()
forall a b. a -> Either a b
Left (String -> Either String String
forall a b. b -> Either a b
Right String
"Payload Too Large")
          else if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsSuccessful (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall a. Response a -> Status
getResponseStatus Response ()
res then
            --aka NonRecoverable
            Either String String -> Either (Either String String) ()
forall a b. a -> Either a b
Left (String -> Either String String
forall a b. a -> Either a b
Left String
"Unexpected Runtime Error: Could not post handler result.")
          else
            --aka Success
            () -> Either (Either String String) ()
forall a b. b -> Either a b
Right ()

  case Either (Either String String) ()
resOrTypedMsg of
    Left (Left String
msg) ->
      -- If an exception occurs here, we want that to propogate
      RuntimeClientConfig -> ByteString -> String -> IO ()
sendEventError RuntimeClientConfig
rcc ByteString
reqId String
msg
    Left (Right String
msg) -> String -> IO ()
forall a. HasCallStack => String -> a
error String
msg
    Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendEventError :: RuntimeClientConfig -> BS.ByteString -> String -> IO ()
sendEventError :: RuntimeClientConfig -> ByteString -> String -> IO ()
sendEventError (RuntimeClientConfig Request
baseRuntimeRequest Manager
manager StaticContext
_) ByteString
reqId String
e =
  (Response () -> ()) -> IO (Response ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Response () -> ()
forall a b. a -> b -> a
const ()) (IO (Response ()) -> IO ()) -> IO (Response ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Response ()) -> IO (Response ())
forall a. IO (Response a) -> IO (Response a)
runtimeClientRetry (IO (Response ()) -> IO (Response ()))
-> IO (Response ()) -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response ()))
-> Manager -> Request -> IO (Response ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager (Request -> IO (Response ())) -> Request -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ ByteString -> String -> Request -> Request
toEventErrorRequest ByteString
reqId String
e Request
baseRuntimeRequest

sendInitError :: Request -> Manager -> String -> IO ()
sendInitError :: Request -> Manager -> String -> IO ()
sendInitError Request
baseRuntimeRequest Manager
manager String
e =
  (Response () -> ()) -> IO (Response ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Response () -> ()
forall a b. a -> b -> a
const ()) (IO (Response ()) -> IO ()) -> IO (Response ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Response ()) -> IO (Response ())
forall a. IO (Response a) -> IO (Response a)
runtimeClientRetry (IO (Response ()) -> IO (Response ()))
-> IO (Response ()) -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response ()))
-> Manager -> Request -> IO (Response ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager (Request -> IO (Response ())) -> Request -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ String -> Request -> Request
toInitErrorRequest String
e Request
baseRuntimeRequest


-- Helpers (mostly) for Headers

exactlyOneHeader :: [a] -> Maybe a
exactlyOneHeader :: [a] -> Maybe a
exactlyOneHeader [a
a] = a -> Maybe a
forall a. a -> Maybe a
Just a
a
exactlyOneHeader [a]
_ = Maybe a
forall a. Maybe a
Nothing

maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither b
b Maybe a
ma = case Maybe a
ma of
  Maybe a
Nothing -> b -> Either b a
forall a b. a -> Either a b
Left b
b
  Just a
a -> a -> Either b a
forall a b. b -> Either a b
Right a
a

-- Note: Does not allow whitespace
readMaybe :: (Read a) => String -> Maybe a
readMaybe :: String -> Maybe a
readMaybe String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
  [(a
x,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
  [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

-- TODO: There must be a better way to do this
decodeHeaderValue :: FromJSON a => BSC.ByteString -> Maybe a
decodeHeaderValue :: ByteString -> Maybe a
decodeHeaderValue = ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe a)
-> (ByteString -> ByteString) -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BSW.pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Word8
BSI.c2w (String -> [Word8])
-> (ByteString -> String) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack

-- An empty array means we successfully decoded, but nothing was there
-- If we have exactly one element, our outer maybe signals successful decode,
--   and our inner maybe signals that there was content sent
-- If we had more than one header value, the event was invalid
decodeOptionalHeader :: FromJSON a => [BSC.ByteString] -> Maybe (Maybe a)
decodeOptionalHeader :: [ByteString] -> Maybe (Maybe a)
decodeOptionalHeader [ByteString]
header =
  case [ByteString]
header of
    [] -> Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
    [ByteString
x] -> (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a)) -> Maybe a -> Maybe (Maybe a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decodeHeaderValue ByteString
x
    [ByteString]
_ -> Maybe (Maybe a)
forall a. Maybe a
Nothing


-- Helpers for Requests with JSON Bodies

httpValue :: Request -> Manager -> IO (Response Value)
httpValue :: Request -> Manager -> IO (Response Value)
httpValue Request
request Manager
manager =
  Request
-> Manager
-> (Response BodyReader -> IO (Response Value))
-> IO (Response Value)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
request Manager
manager (\Response BodyReader
bodyReaderRes -> do
    Value
value <- ConduitT () Void IO Value -> IO Value
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO Value -> IO Value)
-> ConduitT () Void IO Value -> IO Value
forall a b. (a -> b) -> a -> b
$ BodyReader -> ConduitM () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
bodyReaderSource (Response BodyReader -> BodyReader
forall a. Response a -> a
responseBody Response BodyReader
bodyReaderRes) ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO Value -> ConduitT () Void IO Value
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Parser ByteString Value -> ConduitM ByteString Void IO Value
forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
sinkParser Parser ByteString Value
value'
    Response Value -> IO (Response Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Response Value -> IO (Response Value))
-> Response Value -> IO (Response Value)
forall a b. (a -> b) -> a -> b
$ (BodyReader -> Value) -> Response BodyReader -> Response Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> BodyReader -> Value
forall a b. a -> b -> a
const Value
value) Response BodyReader
bodyReaderRes
  )

bodyReaderSource :: MonadIO m
                 => BodyReader
                 -> ConduitM i BS.ByteString m ()
bodyReaderSource :: BodyReader -> ConduitM i ByteString m ()
bodyReaderSource BodyReader
br =
    ConduitM i ByteString m ()
forall i. ConduitT i ByteString m ()
loop
  where
    loop :: ConduitT i ByteString m ()
loop = do
        ByteString
bs <- BodyReader -> ConduitT i ByteString m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BodyReader -> ConduitT i ByteString m ByteString)
-> BodyReader -> ConduitT i ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ BodyReader -> BodyReader
brRead BodyReader
br
        Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
-> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
            ConduitT i ByteString m ()
loop

-- Retry Helpers

runtimeClientRetryTry' :: Int -> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' :: Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' Int
retries Int
maxRetries IO (Response a)
f
  | Int
retries Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxRetries = IO (Response a) -> IO (Either HttpException (Response a))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (Response a)
f
  | Bool
otherwise = do
    Either HttpException (Response a)
resOrEx <- IO (Response a) -> IO (Either HttpException (Response a))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (Response a)
f
    let retry :: IO (Either HttpException (Response a))
retry =
          Int -> IO ()
threadDelay (Int
500 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
retries)
            IO ()
-> IO (Either HttpException (Response a))
-> IO (Either HttpException (Response a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
forall a.
Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' (Int
retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
maxRetries IO (Response a)
f
    case Either HttpException (Response a)
resOrEx of
      Left (HttpException
_ :: HttpException) -> IO (Either HttpException (Response a))
retry
      Right Response a
res ->
        -- TODO: Explore this further.
        -- Before ~July 22nd 2020 it seemed that if a next event request reached
        -- the runtime before a new event was available that there would be a
        -- network error.  After it appears that a 403 is returned.
        if Response a -> Status
forall a. Response a -> Status
getResponseStatus Response a
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status403 then IO (Either HttpException (Response a))
retry
        else Either HttpException (Response a)
-> IO (Either HttpException (Response a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpException (Response a)
 -> IO (Either HttpException (Response a)))
-> Either HttpException (Response a)
-> IO (Either HttpException (Response a))
forall a b. (a -> b) -> a -> b
$ Response a -> Either HttpException (Response a)
forall a b. b -> Either a b
Right Response a
res

runtimeClientRetryTry :: IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry :: IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry = Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
forall a.
Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' Int
0 Int
10

runtimeClientRetry :: IO (Response a) -> IO (Response a)
runtimeClientRetry :: IO (Response a) -> IO (Response a)
runtimeClientRetry = (Either HttpException (Response a) -> Response a)
-> IO (Either HttpException (Response a)) -> IO (Response a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HttpException -> Response a)
-> (Response a -> Response a)
-> Either HttpException (Response a)
-> Response a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HttpException -> Response a
forall a e. Exception e => e -> a
throw Response a -> Response a
forall a. a -> a
id) (IO (Either HttpException (Response a)) -> IO (Response a))
-> (IO (Response a) -> IO (Either HttpException (Response a)))
-> IO (Response a)
-> IO (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response a) -> IO (Either HttpException (Response a))
forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry


-- Request Transformers

toNextEventRequest :: Request -> Request
toNextEventRequest :: Request -> Request
toNextEventRequest = ByteString -> Request -> Request
setRequestPath ByteString
"2018-06-01/runtime/invocation/next"

toEventSuccessRequest :: ToJSON a => BS.ByteString -> a -> Request -> Request
toEventSuccessRequest :: ByteString -> a -> Request -> Request
toEventSuccessRequest ByteString
reqId a
json =
  a -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON a
json (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ByteString -> Request -> Request
setRequestMethod ByteString
"POST" (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ByteString -> Request -> Request
setRequestPath ([ByteString] -> ByteString
BS.concat [ByteString
"2018-06-01/runtime/invocation/", ByteString
reqId, ByteString
"/response"])

toBaseErrorRequest :: String -> Request -> Request
toBaseErrorRequest :: String -> Request -> Request
toBaseErrorRequest String
e =
  ByteString -> Request -> Request
setRequestBodyLBS (LambdaError -> ByteString
forall a. ToJSON a => a -> ByteString
encode (LambdaError :: String -> String -> [String] -> LambdaError
LambdaError { $sel:errorMessage:LambdaError :: String
errorMessage = String
e, $sel:stackTrace:LambdaError :: [String]
stackTrace = [], $sel:errorType:LambdaError :: String
errorType = String
"User"}))
    (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Content-Type" [ByteString
"application/vnd.aws.lambda.error+json"]
    (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setRequestMethod ByteString
"POST"
    (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
setRequestCheckStatus

toEventErrorRequest :: BS.ByteString -> String -> Request -> Request
toEventErrorRequest :: ByteString -> String -> Request -> Request
toEventErrorRequest ByteString
reqId String
e =
  ByteString -> Request -> Request
setRequestPath ([ByteString] -> ByteString
BS.concat [ByteString
"2018-06-01/runtime/invocation/", ByteString
reqId, ByteString
"/error"]) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Request -> Request
toBaseErrorRequest String
e

toInitErrorRequest :: String -> Request -> Request
toInitErrorRequest :: String -> Request -> Request
toInitErrorRequest String
e =
  ByteString -> Request -> Request
setRequestPath ByteString
"2018-06-01/runtime/init/error" (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Request -> Request
toBaseErrorRequest String
e