module AWS.Lambda.RuntimeClient (
RuntimeClientConfig,
getRuntimeClientConfig,
getNextEvent,
sendEventSuccess,
sendEventError,
sendInitError
) where
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, displayException, throw,
try)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (Result (..), Value, encode,
fromJSON)
import Data.Aeson.Parser (value')
import Data.Aeson.Types (FromJSON, ToJSON)
import Data.Bifunctor (first)
import qualified Data.ByteString as BS
import Data.Conduit (ConduitM, runConduit, yield, (.|))
import Data.Conduit.Attoparsec (sinkParser)
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 (getResponseStatus,
setRequestBodyJSON,
setRequestBodyLBS,
setRequestCheckStatus,
setRequestHeader, setRequestMethod,
setRequestPath)
import Network.HTTP.Types.Status (status403, status413, statusIsSuccessful)
import System.Environment (getEnv)
data LambdaError = LambdaError
{ errorMessage :: String,
errorType :: String,
stackTrace :: [String]
} deriving (Show, Generic)
instance ToJSON LambdaError
data RuntimeClientConfig = RuntimeClientConfig Request Manager
getRuntimeClientConfig :: IO RuntimeClientConfig
getRuntimeClientConfig = do
awsLambdaRuntimeApi <- getEnv "AWS_LAMBDA_RUNTIME_API"
req <- parseRequest $ "http://" ++ awsLambdaRuntimeApi
man <- newManager
$ managerSetProxy noProxy
$ defaultManagerSettings
{ managerResponseTimeout = responseTimeoutNone
, managerConnCount = 1
, managerIdleConnectionCount = 1
}
return $ RuntimeClientConfig req man
getNextEvent :: FromJSON a => RuntimeClientConfig -> IO (Response (Either JSONParseException a))
getNextEvent rcc@(RuntimeClientConfig baseRuntimeRequest manager) = do
resOrEx <- runtimeClientRetryTry $ flip httpJSONEither manager $ toNextEventRequest baseRuntimeRequest
let checkStatus res = if not $ statusIsSuccessful $ getResponseStatus res then
Left "Unexpected Runtime Error: Could not retrieve next event."
else
Right res
let resOrMsg = first (displayException :: HttpException -> String) resOrEx >>= checkStatus
case resOrMsg of
Left msg -> do
_ <- sendInitError rcc msg
error msg
Right y -> return y
sendEventSuccess :: ToJSON a => RuntimeClientConfig -> BS.ByteString -> a -> IO ()
sendEventSuccess rcc@(RuntimeClientConfig baseRuntimeRequest manager) reqId json = do
resOrEx <- runtimeClientRetryTry $ flip httpNoBody manager $ toEventSuccessRequest reqId json baseRuntimeRequest
let resOrTypedMsg = case resOrEx of
Left ex ->
Left $ Left $ displayException (ex :: HttpException)
Right res ->
if getResponseStatus res == status413 then
Left (Right "Payload Too Large")
else if not $ statusIsSuccessful $ getResponseStatus res then
Left (Left "Unexpected Runtime Error: Could not post handler result.")
else
Right ()
case resOrTypedMsg of
Left (Left msg) ->
sendEventError rcc reqId msg
Left (Right msg) -> error msg
Right () -> return ()
sendEventError :: RuntimeClientConfig -> BS.ByteString -> String -> IO ()
sendEventError (RuntimeClientConfig baseRuntimeRequest manager) reqId e =
fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toEventErrorRequest reqId e baseRuntimeRequest
sendInitError :: RuntimeClientConfig -> String -> IO ()
sendInitError (RuntimeClientConfig baseRuntimeRequest manager) e =
fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toInitErrorRequest e baseRuntimeRequest
newtype JSONParseException = JSONParseException { getException :: String } deriving (Show)
instance Exception JSONParseException
httpJSONEither :: FromJSON a => Request -> Manager -> IO (Response (Either JSONParseException a))
httpJSONEither request manager =
let toEither v =
case fromJSON v of
Error e -> Left (JSONParseException e)
Success decoded -> Right decoded
in fmap toEither <$> httpValue request manager
httpValue :: Request -> Manager -> IO (Response Value)
httpValue request manager =
withResponse request manager (\bodyReaderRes -> do
value <- runConduit $ bodyReaderSource (responseBody bodyReaderRes) .| sinkParser value'
return $ fmap (const value) bodyReaderRes
)
bodyReaderSource :: MonadIO m
=> BodyReader
-> ConduitM i BS.ByteString m ()
bodyReaderSource br =
loop
where
loop = do
bs <- liftIO $ brRead br
unless (BS.null bs) $ do
yield bs
loop
runtimeClientRetryTry' :: Int -> Int -> IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry' retries maxRetries f
| retries == maxRetries = try f
| otherwise = do
resOrEx <- try f
let retry =
threadDelay (500 * 2 ^ retries)
>> runtimeClientRetryTry' (retries + 1) maxRetries f
case resOrEx of
Left (_ :: HttpException) -> retry
Right res ->
if getResponseStatus res == status403 then retry
else return $ Right res
runtimeClientRetryTry :: IO (Response a) -> IO (Either HttpException (Response a))
runtimeClientRetryTry = runtimeClientRetryTry' 0 10
runtimeClientRetry :: IO (Response a) -> IO (Response a)
runtimeClientRetry = fmap (either throw id) . runtimeClientRetryTry
toNextEventRequest :: Request -> Request
toNextEventRequest = setRequestPath "2018-06-01/runtime/invocation/next"
toEventSuccessRequest :: ToJSON a => BS.ByteString -> a -> Request -> Request
toEventSuccessRequest reqId json =
setRequestBodyJSON json .
setRequestMethod "POST" .
setRequestPath (BS.concat ["2018-06-01/runtime/invocation/", reqId, "/response"])
toBaseErrorRequest :: String -> Request -> Request
toBaseErrorRequest e =
setRequestBodyLBS (encode (LambdaError { errorMessage = e, stackTrace = [], errorType = "User"}))
. setRequestHeader "Content-Type" ["application/vnd.aws.lambda.error+json"]
. setRequestMethod "POST"
. setRequestCheckStatus
toEventErrorRequest :: BS.ByteString -> String -> Request -> Request
toEventErrorRequest reqId e =
setRequestPath (BS.concat ["2018-06-01/runtime/invocation/", reqId, "/error"]) . toBaseErrorRequest e
toInitErrorRequest :: String -> Request -> Request
toInitErrorRequest e =
setRequestPath "2018-06-01/runtime/init/error" . toBaseErrorRequest e