{-# LANGUAGE CPP #-}
{-|
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               (StaticContext, getStaticContext)
import           AWS.Lambda.RuntimeClient.Internal (eventResponseToNextData)
import           Control.Concurrent                (threadDelay)
import           Control.Exception                 (IOException, displayException,
                                                    throw, try)
import           Control.Monad                     (unless, void)
import           Control.Monad.IO.Class            (MonadIO, liftIO)
import           Data.Aeson                        (Value, encode)
import           Data.Aeson.Parser                 (value')
import           Data.Aeson.Types                  (ToJSON)
import           Data.Bifunctor                    (first)
import qualified Data.ByteString                   as BS
import qualified Data.ByteString.Lazy              as BSW
import           Data.Conduit                      (ConduitM, runConduit, yield,
                                                    (.|))
import           Data.Conduit.Attoparsec           (sinkParser)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup                    ((<>))
#endif
import           GHC.Generics                      (Generic (..))
import           Network.HTTP.Client               (BodyReader, HttpException,
                                                    Manager, Request,
                                                    RequestBody (RequestBodyLBS),
                                                    Response, brRead,
                                                    defaultManagerSettings,
                                                    httpNoBody,
                                                    managerConnCount,
                                                    managerIdleConnectionCount,
                                                    managerResponseTimeout,
                                                    managerSetProxy, method,
                                                    newManager, noProxy,
                                                    parseRequest, path,
                                                    requestBody, requestHeaders,
                                                    responseBody,
                                                    responseStatus,
                                                    responseTimeoutNone,
                                                    setRequestCheckStatus,
                                                    withResponse)
import           Network.HTTP.Types                (HeaderName)
import           Network.HTTP.Types.Status         (Status, status403,
                                                    status413,
                                                    statusIsSuccessful)
import           System.Environment                (getEnv)
import           System.IO                         (hPutStrLn, stderr)

-- | 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
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. 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 <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ String
"http://" 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.
           forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetProxy ProxyOverride
noProxy
           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 <-
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. Exception e => e -> String
displayException :: IOException -> String) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try IO StaticContext
getStaticContext

  case Either String StaticContext
possibleStaticCtx of
    Left String
err -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> String -> IO ()
sendInitError Request
req Manager
man String
err
      forall a. HasCallStack => String -> a
error String
err
    Right StaticContext
staticCtx -> forall (m :: * -> *) a. Monad m => a -> m a
return 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) =
  StaticContext
-> Response Value
-> (ByteString, Value, Either String LambdaContext)
eventResponseToNextData StaticContext
staticContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuntimeClientConfig -> IO (Response Value)
getNextEvent RuntimeClientConfig
runtimeClientConfig

-- 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 <- forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response Value)
httpValue Manager
manager 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 forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsSuccessful forall a b. (a -> b) -> a -> b
$ forall a. Response a -> Status
getResponseStatus Response a
res then
        forall a b. a -> Either a b
Left a
"Unexpected Runtime Error:  Could not retrieve next event."
      else
        forall a b. b -> Either a b
Right Response a
res
  let resOrMsg :: Either String (Response Value)
resOrMsg = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. Exception e => e -> String
displayException :: HttpException -> String) Either HttpException (Response Value)
resOrEx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
      forall a. HasCallStack => String -> a
error String
msg
    Right Response Value
y -> forall (m :: * -> *) a. Monad m => a -> m a
return Response Value
y

sendEventSuccess :: ToJSON a => RuntimeClientConfig -> BS.ByteString -> a -> IO ()
sendEventSuccess :: forall a.
ToJSON a =>
RuntimeClientConfig -> ByteString -> a -> IO ()
sendEventSuccess rcc :: RuntimeClientConfig
rcc@(RuntimeClientConfig Request
baseRuntimeRequest Manager
manager StaticContext
_) ByteString
reqId a
json = do
  Either HttpException (Response ())
resOrEx <- forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager forall a b. (a -> b) -> a -> b
$ 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
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException (HttpException
ex :: HttpException)
        Right Response ()
res ->
          if forall a. Response a -> Status
getResponseStatus Response ()
res forall a. Eq a => a -> a -> Bool
== Status
status413 then
            -- TODO Get the real error info from the response
            -- aka Recoverable
            forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right String
"Payload Too Large")
          else if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsSuccessful forall a b. (a -> b) -> a -> b
$ forall a. Response a -> Status
getResponseStatus Response ()
res then
            --aka NonRecoverable
            forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left String
"Unexpected Runtime Error: Could not post handler result.")
          else
            --aka Success
            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) -> forall a. HasCallStack => String -> a
error String
msg
    Right () -> 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 = do
  String -> IO ()
logErrorMsg String
e
  let request :: IO (Response ())
request = Request -> Manager -> IO (Response ())
httpNoBody (ByteString -> String -> Request -> Request
toEventErrorRequest ByteString
reqId String
e Request
baseRuntimeRequest) Manager
manager
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO (Response a) -> IO (Response a)
runtimeClientRetry IO (Response ())
request

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


-- Helpers for Requests with JSON Bodies

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

bodyReaderSource :: MonadIO m
                 => BodyReader
                 -> ConduitM i BS.ByteString m ()
bodyReaderSource :: forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
bodyReaderSource BodyReader
br =
    forall {i}. ConduitT i ByteString m ()
loop
  where
    loop :: ConduitT i ByteString m ()
loop = do
        ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BodyReader -> BodyReader
brRead BodyReader
br
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
            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' :: forall a.
Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' Int
retries Int
maxRetries IO (Response a)
f
  | Int
retries forall a. Eq a => a -> a -> Bool
== Int
maxRetries = forall e a. Exception e => IO a -> IO (Either e a)
try IO (Response a)
f
  | Bool
otherwise = do
    Either HttpException (Response a)
resOrEx <- 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 forall a. Num a => a -> a -> a
* Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
retries)
            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a.
Int
-> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' (Int
retries 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 forall a. Response a -> Status
getResponseStatus Response a
res forall a. Eq a => a -> a -> Bool
== Status
status403 then IO (Either HttpException (Response a))
retry
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Response a
res

runtimeClientRetryTry :: IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry :: forall a. IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry = 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 :: forall a. IO (Response a) -> IO (Response a)
runtimeClientRetry = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. ToJSON a => ByteString -> a -> Request -> Request
toEventSuccessRequest ByteString
reqId a
json =
  forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON a
json forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ByteString -> Request -> Request
setRequestMethod ByteString
"POST" 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 (forall a. ToJSON a => a -> ByteString
encode (LambdaError { $sel:errorMessage:LambdaError :: String
errorMessage = String
e, $sel:stackTrace:LambdaError :: [String]
stackTrace = [], $sel:errorType:LambdaError :: String
errorType = String
"User"}))
    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"]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setRequestMethod ByteString
"POST"
    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"]) 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" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Request -> Request
toBaseErrorRequest String
e


-- HTTP Client Type Helpers

getResponseStatus :: Response a -> Status
getResponseStatus :: forall a. Response a -> Status
getResponseStatus = forall a. Response a -> Status
responseStatus

setRequestBodyJSON :: ToJSON a => a -> Request -> Request
setRequestBodyJSON :: forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON = ByteString -> Request -> Request
setRequestBodyLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode

setRequestBodyLBS :: BSW.ByteString -> Request -> Request
setRequestBodyLBS :: ByteString -> Request -> Request
setRequestBodyLBS ByteString
body Request
req = Request
req { requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body }

setRequestHeader :: HeaderName -> [BS.ByteString] -> Request -> Request
setRequestHeader :: HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
headerName [ByteString]
values Request
req =
  let
    withoutPrevious :: [Header]
withoutPrevious = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(/=) HeaderName
headerName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Request -> [Header]
requestHeaders Request
req
    withNew :: [Header]
withNew = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) HeaderName
headerName) [ByteString]
values forall a. Semigroup a => a -> a -> a
<> [Header]
withoutPrevious
  in
    Request
req { requestHeaders :: [Header]
requestHeaders = [Header]
withNew }

setRequestMethod :: BS.ByteString -> Request -> Request
setRequestMethod :: ByteString -> Request -> Request
setRequestMethod ByteString
m Request
req = Request
req { method :: ByteString
method = ByteString
m }

setRequestPath :: BS.ByteString -> Request -> Request
setRequestPath :: ByteString -> Request -> Request
setRequestPath ByteString
p Request
req = Request
req { path :: ByteString
path = ByteString
p }

-- Log Helpers

-- TODO: This logging more-or-less looks like other runtimes, but there doesn't
-- seem to be any specific standard or recommendations around this, and it
-- varies across runtimes.  In the future, it may make sense to enable user
-- specific formatting (similar to the Rust runtime).  But for now, not sure
-- we'll ever see such an ask.
logErrorMsg :: String -> IO ()
logErrorMsg :: String -> IO ()
logErrorMsg = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => a -> a -> a
(<>) String
"ERROR Message: " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show