diff --git a/infernal.cabal b/infernal.cabal --- a/infernal.cabal +++ b/infernal.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4ab0e10451e82405d58538179329227b563bbfed77824227cd8020b2bc301df6 +-- hash: a5e5af8e888606c56383340240a1e597cd6d9b3925850095b0ccd08074d9b07c name: infernal -version: 0.2.0 +version: 0.3.0 synopsis: The Infernal Machine - An AWS Lambda Custom Runtime for Haskell description: Please see the README on GitHub at category: AWS @@ -27,12 +27,14 @@ library exposed-modules: Infernal + Infernal.Events.APIGateway + Infernal.Wai other-modules: Paths_infernal hs-source-dirs: src default-extensions: ConstraintKinds DeriveFunctor DeriveFoldable DeriveGeneric DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings TemplateHaskell - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -fno-warn-warnings-deprecations build-depends: aeson >=1.4 , base >=4.12 && <5 diff --git a/src/Infernal.hs b/src/Infernal.hs --- a/src/Infernal.hs +++ b/src/Infernal.hs @@ -10,18 +10,21 @@ , LambdaError (..) , LambdaRequestId (..) , LambdaRequest (..) + , LambdaResponse (..) , LambdaVars (..) , RunCallback , UncaughtErrorCallback + , decodeRequest , defaultCallbackConfig , defaultLambdaError , defaultInitErrorCallback + , encodeResponse , runLambda , runSimpleLambda ) where import Control.Monad (forever, void) -import Data.Aeson (encode, pairs, (.=)) +import Data.Aeson (eitherDecode, encode, pairs, (.=)) import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI import Data.Maybe (isJust) @@ -52,9 +55,14 @@ , _lreqBody :: !LBS.ByteString -- ^ The unparsed request body. Typically you will 'Data.Aeson.decode' this. } deriving stock (Eq, Show) +-- | A response to the 'LambdaRequest', typically as encoded JSON. +newtype LambdaResponse = LambdaResponse + { _unLambdaResponse :: LBS.ByteString + } deriving (Eq, Show, Ord, IsString, Hashable) + -- | An error formatted to propagate to AWS (). --- Note that this is an 'Exception' so you can throw it to short-circuit processing and report useful information. If you throw anything --- else a 'defaultLambdaError' will be reported with no useful information. +-- Note that this is an 'Exception' so you can throw it to short-circuit processing and report useful information. By default, if you throw +-- anything else a 'defaultLambdaError' will be reported with no useful information. data LambdaError = LambdaError { _lerrErrorType :: !Text -- ^ The type of error that occurred. In this library is is often @StartCase@-formated. , _lerrErrorMessage :: !Text -- ^ A useful error message @@ -102,7 +110,7 @@ type GetLambdaRequest m = m LambdaRequest type PostLambdaInitError m = LambdaError -> m () type PostLambdaInvokeError m = LambdaRequestId -> LambdaError -> m () -type PostLambdaResponse m = LambdaRequestId -> LBS.ByteString -> m () +type PostLambdaResponse m = LambdaRequestId -> LambdaResponse -> m () data LambdaClient m = LambdaClient { _lcGetLambdaRequest :: !(GetLambdaRequest m) @@ -123,7 +131,7 @@ -- callbacks will process it. Most importantly, 'LambdaError' will propagate a formatted error to AWS, and 'System.Exit.ExitCode' will halt the program. Except for 'System.Exit.ExitCode', -- throwing exceptions here will not terminate the main loop (see 'runLambda'). Note that the AWS custom runtime loop implemented in this library is single-threaded (as required - we must finish an invocation -- before fetching the next) but you are free to spawn threads in your callback. -type RunCallback n = LambdaRequest -> n LBS.ByteString +type RunCallback n = LambdaRequest -> n LambdaResponse -- | Error mapper for invocation errors. The result will be @POST@ed to the invocation error endpoint (). -- Exceptions of type 'LambdaError' will not trigger this callback, and 'System.Exit.ExitCode' will be rethrown after it executes. @@ -321,7 +329,7 @@ postLambdaInvokeErrorImpl lamReqId = postRequest ["invocation", _unLambdaRequestId lamReqId, "error"] . encode postLambdaResponseImpl :: MonadLambdaImpl env m => PostLambdaResponse m -postLambdaResponseImpl lamReqId = postRequest ["invocation", _unLambdaRequestId lamReqId, "response"] +postLambdaResponseImpl lamReqId = postRequest ["invocation", _unLambdaRequestId lamReqId, "response"] . _unLambdaResponse lambdaClientImpl :: MonadLambdaImpl env m => LambdaClient m lambdaClientImpl = LambdaClient @@ -337,6 +345,17 @@ -- TODO This should go in heart-core, along with catch functions unliftRIO :: MonadIO m => env -> m (UnliftIO (RIO env)) unliftRIO env = liftIO (runRIO env askUnliftIO) + +badRequestError :: Text -> LambdaError +badRequestError reason = LambdaError "BadRequestError" ("Bad request: " <> reason) + +-- | Decodes a request with 'FromJSON' or throws a 'LambdaError' (@BadRequestError@). +decodeRequest :: (MonadThrow m, FromJSON a) => LambdaRequest -> m a +decodeRequest = either (throwM . badRequestError . Text.pack) pure . eitherDecode . _lreqBody + +-- | Encodes a response with 'ToJSON'. (Mostly here to save you an Aeson import.) +encodeResponse :: ToJSON a => a -> LambdaResponse +encodeResponse = LambdaResponse . encode -- | The full-powered entrypoint underlying 'runSimpleLambda' that allows you to use any 'UnliftIO'-capable monad for your callbacks. -- This runs the main loop of our AWS Lambda Custom Runtime to fetch invocations, process them, and report errors or results. diff --git a/src/Infernal/Events/APIGateway.hs b/src/Infernal/Events/APIGateway.hs new file mode 100644 --- /dev/null +++ b/src/Infernal/Events/APIGateway.hs @@ -0,0 +1,84 @@ +{-| +Definitions for API Gateway proxy objects. Where possible, information that maps directly +to 'Network.HTTP.Types' objects uses that representation. Otherwise a 'Text' representation +is used as 'Data.Aeson' natively provides. + +See for +information on these datatypes. + +These definitions are taken in part from . +Attribution and license information are present in the README. +-} +module Infernal.Events.APIGateway + ( APIGatewayProxyRequest (..) + , APIGatewayProxyResponse (..) + ) where + +import Data.Aeson (object, withObject, (.!=), (.:), (.:?), (.=)) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Heart.Core.Prelude +import qualified Network.HTTP.Types as HT + +fromAWSQuery :: HashMap Text Text -> HT.Query +fromAWSQuery = fmap toQueryItem . HashMap.toList where + toQueryItem = bimap encodeUtf8 (\x -> if Text.null x then Nothing else Just (encodeUtf8 x)) + +toAWSHeaders :: HT.ResponseHeaders -> HashMap Text Text +toAWSHeaders = HashMap.fromList . fmap (bimap (decodeUtf8 . CI.original) decodeUtf8) + +fromAWSHeaders :: HashMap Text Text -> HT.RequestHeaders +fromAWSHeaders = fmap toHeader . HashMap.toList where + toHeader = bimap (CI.mk . encodeUtf8) encodeUtf8 + +-- | An API Gateway proxy request +data APIGatewayProxyRequest = APIGatewayProxyRequest + { _agprqResource :: !Text + , _agprqPath :: !ByteString + , _agprqHttpMethod :: !HT.Method + , _agprqHeaders :: !HT.RequestHeaders + , _agprqQueryStringParameters :: !HT.Query + , _agprqPathParameters :: !(HashMap Text Text) + , _agprqStageVariables :: !(HashMap Text Text) + , _agprqBody :: !(Maybe ByteString) + } deriving (Eq, Show, Generic) + +instance FromJSON APIGatewayProxyRequest where + parseJSON = + withObject "APIGatewayProxyRequest" $ \o -> + APIGatewayProxyRequest + <$> o .: "resource" + <*> (encodeUtf8 <$> o .: "path") + <*> (encodeUtf8 <$> o .: "httpMethod") + <*> (fmap fromAWSHeaders <$> o .:? "headers") .!= mempty + <*> (fmap fromAWSQuery <$> o .:? "queryStringParameters") .!= mempty + <*> o .:? "pathParameters" .!= HashMap.empty + <*> o .:? "stageVariables" .!= HashMap.empty + <*> (fmap encodeUtf8 <$> o .:? "body") + +-- | An API Gateway proxy response +data APIGatewayProxyResponse = APIGatewayProxyResponse + { _agprsStatusCode :: !Int + , _agprsHeaders :: !HT.ResponseHeaders + , _agprsBody :: !(Maybe ByteString) + } deriving (Eq, Show) + +instance ToJSON APIGatewayProxyResponse where + toJSON rep = + object + [ "statusCode" .= _agprsStatusCode rep + , "headers" .= toAWSHeaders (_agprsHeaders rep) + , "body" .= fmap decodeUtf8 (_agprsBody rep) + ] + +instance FromJSON APIGatewayProxyResponse where + parseJSON = + withObject "APIGatewayProxyResponse" $ \o -> + APIGatewayProxyResponse + <$> o .: "statusCode" + <*> (fromAWSHeaders <$> o .: "headers") + <*> (fmap encodeUtf8 <$> o .:? "body") diff --git a/src/Infernal/Wai.hs b/src/Infernal/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Infernal/Wai.hs @@ -0,0 +1,82 @@ +{-| +Functions to let you wrap WAI Applications and use them to serve API Gateway requests. +See 'runSimpleWaiLambda' for a simple entrypoint. +-} +module Infernal.Wai + ( adaptApplication + , adaptRequest + , adaptResponse + , applicationCallback + , runSimpleWaiLambda + ) where + +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Data.Binary.Builder (Builder, toLazyByteString) +import qualified Data.ByteString as ByteString +import Data.ByteString.Lazy (toStrict) +import Data.IORef (modifyIORef', newIORef, readIORef) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Heart.App.Logging (WithSimpleLog, logDebug) +import Heart.Core.Prelude +import Infernal (RunCallback, decodeRequest, encodeResponse, runSimpleLambda) +import Infernal.Events.APIGateway (APIGatewayProxyRequest (..), APIGatewayProxyResponse (..)) +import Network.Wai (Application, Response, StreamingBody, defaultRequest, responseToStream) +import Network.Wai.Internal (Request (..), ResponseReceived (..)) + +-- | Turn an 'APIGatewayProxyRequest' into a WAI 'Request'. (Not all fields will be present!) +adaptRequest :: APIGatewayProxyRequest -> Request +adaptRequest proxyReq = + defaultRequest + { requestMethod = _agprqHttpMethod proxyReq + , rawPathInfo = _agprqPath proxyReq + , pathInfo = dropWhile Text.null (Text.split (=='/') (decodeUtf8 (_agprqPath proxyReq))) + , queryString = _agprqQueryStringParameters proxyReq + , requestHeaders = _agprqHeaders proxyReq + , requestBody = maybe empty pure (_agprqBody proxyReq) + } + +consumeStream :: StreamingBody -> IO Builder +consumeStream sb = do + r <- newIORef mempty + sb (modifyIORef' r . flip mappend) (pure ()) + readIORef r + +-- | Turn a WAI 'Response' into an 'APIGatewayProxyResponse', materializing the whole response body. +adaptResponse :: MonadIO n => Response -> n APIGatewayProxyResponse +adaptResponse rep = do + let (repStatus, repHeaders, repBodyAction) = responseToStream rep + bodyBuilder <- liftIO (repBodyAction consumeStream) + let body = toStrict (toLazyByteString bodyBuilder) + pure APIGatewayProxyResponse + { _agprsStatusCode = fromEnum repStatus + , _agprsHeaders = repHeaders + , _agprsBody = if ByteString.null body then Nothing else Just body + } + +-- | Adapt a WAI 'Application' into a function that handles API Gateway proxy requests. +adaptApplication :: MonadIO n => Application -> APIGatewayProxyRequest -> n APIGatewayProxyResponse +adaptApplication app proxyReq = do + v <- liftIO newEmptyMVar + let req = adaptRequest proxyReq + _ <- liftIO $ app req $ \res -> do + proxyRes <- adaptResponse res + putMVar v proxyRes + pure ResponseReceived + liftIO (takeMVar v) + +-- | Adapt a WAI 'Application' into a 'RunCallback' to handle API Gateway proxy requests encoded as Lambda requests. +applicationCallback :: (MonadThrow n, WithSimpleLog env n) => Application -> RunCallback n +applicationCallback app lamReq = do + proxyReq <- decodeRequest lamReq + logDebug ("Servicing proxy request " <> decodeUtf8 (_agprqHttpMethod proxyReq) <> " " <> decodeUtf8 (_agprqPath proxyReq)) + proxyRep <- adaptApplication app proxyReq + logDebug ("Responding with status " <> Text.pack (show (_agprsStatusCode proxyRep))) + let lamRep = encodeResponse proxyRep + pure lamRep + +-- | A simple entrypoint to run your WAI 'Application' in a Lambda function. (See 'runSimpleLambda' for more information on these entrypoints.) +-- You can configure API Gateway to send proxied HTTP requests as JSON to your Lambda (as 'APIGatewayProxyRequest') and have your WAI Application +-- service them with this entrypoint. (Correct API Gateway configuration is pretty tricky, so consult all the documentation available to figure it out.) +runSimpleWaiLambda :: Application -> IO () +runSimpleWaiLambda = runSimpleLambda . applicationCallback