diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for aws-lambda-haskell-runtime-wai + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dobromir Nikolov (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dobromir Nikolov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +# aws-lambda-haskell-runtime-wai ![Haskell CI](https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai/workflows/Haskell%20CI/badge.svg) + +## Quick start + +1. Set up your project to use AWS Lambda by following the instructions on the [aws-lambda-haskell-runtime website](https://theam.github.io/aws-lambda-haskell-runtime/). +2. Use the `waiHandler` function from `AWS.Lambda.Wai` to convert your [`wai`](https://hackage.haskell.org/package/wai) application to a handler. There are two ways to do this. + +```haskell +-- 1. Pass in the initializeApplicationFunction +-- this will call initializeApplication per each call +handler :: WaiHandler () +handler = waiHandler initializeApplication + +-- Wai application initialization logic +initializeApplication :: IO Application +initializeApplication = ... +``` + +```haskell +-- 2. Store the Application inside your custom context and provide a getter function +-- this will initialize the application once per cold start and keep it alive while the lambda is warm +handler :: WaiHandler MyAppConfig +handler = waiHandler' getWaiApp + +data MyAppConfig = + MyAppConfig + { getWaiApp :: Application } +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aws-lambda-haskell-runtime-wai.cabal b/aws-lambda-haskell-runtime-wai.cabal new file mode 100644 --- /dev/null +++ b/aws-lambda-haskell-runtime-wai.cabal @@ -0,0 +1,76 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 84d5705be40077a09e34d445f54b862f58447fa5abac05fd535936a3196c6bbb + +name: aws-lambda-haskell-runtime-wai +version: 1.0.0 +synopsis: Run wai applications on AWS Lambda +description: Please see the README on GitHub at +category: AWS +homepage: https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai#readme +bug-reports: https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai/issues +author: Dobromir Nikolov +maintainer: dnikolovv@hotmail.com +copyright: Eir Försäkring +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai + +library + exposed-modules: + Aws.Lambda.Wai + other-modules: + Paths_aws_lambda_haskell_runtime_wai + hs-source-dirs: + src + build-depends: + aeson + , aws-lambda-haskell-runtime >=3.0.0 + , base >=4.7 && <5 + , binary + , bytestring + , case-insensitive + , http-types + , iproute + , network + , text + , unordered-containers + , vault + , wai + default-language: Haskell2010 + +test-suite aws-lambda-haskell-runtime-wai-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_aws_lambda_haskell_runtime_wai + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aws-lambda-haskell-runtime >=3.0.0 + , aws-lambda-haskell-runtime-wai + , base >=4.7 && <5 + , binary + , bytestring + , case-insensitive + , http-types + , iproute + , network + , text + , unordered-containers + , vault + , wai + default-language: Haskell2010 diff --git a/src/Aws/Lambda/Wai.hs b/src/Aws/Lambda/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Lambda/Wai.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Aws.Lambda.Wai (waiHandler, waiHandler', WaiHandler) where + +import Aws.Lambda +import Control.Concurrent.MVar +import Data.Aeson +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Binary.Builder as Binary +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HMap +import Data.IORef +import qualified Data.IP as IP +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import qualified Data.Text.Encoding as T +import qualified Data.Vault.Lazy as Vault +import GHC.IO.Unsafe (unsafePerformIO) +import qualified Network.HTTP.Types as H +import qualified Network.Socket as Socket +import Network.Wai (Application) +import qualified Network.Wai as Wai +import qualified Network.Wai.Internal as Wai +import Text.Read (readMaybe) + +type WaiHandler context = ApiGatewayRequest Text -> Context context -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)) + +waiHandler :: forall context. IO Wai.Application -> WaiHandler context +waiHandler initApp gatewayRequest context = initApp >>= + \app -> waiHandler'' app gatewayRequest context + +waiHandler' :: forall context. (context -> Wai.Application) -> WaiHandler context +waiHandler' getApp request context = do + app <- getApp <$> readIORef (customContext context) + waiHandler'' app request context + +waiHandler'' :: forall context. Wai.Application -> WaiHandler context +waiHandler'' waiApplication gatewayRequest _ = do + waiRequest <- mkWaiRequest gatewayRequest + + (status, headers, body) <- processRequest waiApplication waiRequest >>= readResponse + + print $ "Working: " <> ("Something went wai" :: ByteString) + print $ "Actual response body (before decodeUtf8'): " <> body + + if BS.null body + then return . pure . wrapInResponse (H.statusCode status) headers $ mempty + else case decodeUtf8' body of + Right responseBodyText -> do + print $ "After decoding in wai: " <> responseBodyText + return . pure . wrapInResponse (H.statusCode status) headers $ responseBodyText + Left err -> error "Expected a response body that is valid UTF-8." + +mkWaiRequest :: ApiGatewayRequest Text -> IO Wai.Request +mkWaiRequest ApiGatewayRequest{..} = do + let ApiGatewayRequestContext{..} = apiGatewayRequestRequestContext + ApiGatewayRequestContextIdentity{..} = apiGatewayRequestContextIdentity + + ip <- parseIp apiGatewayRequestContextIdentitySourceIp + + let pathInfo = H.decodePathSegments (encodeUtf8 apiGatewayRequestPath) + + let requestBodyRaw = maybe mempty T.encodeUtf8 apiGatewayRequestBody + let requestBodyLength = Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw + + requestBodyMVar <- newMVar requestBodyRaw + + let requestBody = takeRequestBodyChunk requestBodyMVar + let requestHeaderHost = encodeUtf8 <$> HMap.lookup "host" apiGatewayRequestHeaders + let requestHeaderRange = encodeUtf8 <$> HMap.lookup "range" apiGatewayRequestHeaders + let requestHeaderReferer = encodeUtf8 <$> HMap.lookup "referer" apiGatewayRequestHeaders + let requestHeaderUserAgent = encodeUtf8 <$> HMap.lookup "User-Agent" apiGatewayRequestHeaders + + let queryParameters = toQueryStringParameters apiGatewayRequestQueryStringParameters + rawQueryString = H.renderQuery True queryParameters + httpVersion = getHttpVersion apiGatewayRequestContextProtocol + + let result = Wai.Request + (encodeUtf8 apiGatewayRequestHttpMethod) + httpVersion + (encodeUtf8 apiGatewayRequestPath) + rawQueryString + (map toHeader $ HMap.toList apiGatewayRequestHeaders) + True -- We assume it's always secure as we're passing through API Gateway + ip + pathInfo + queryParameters + requestBody + Vault.empty + requestBodyLength + requestHeaderHost + requestHeaderRange + requestHeaderReferer + requestHeaderUserAgent + + return result + +getHttpVersion :: Text -> H.HttpVersion +getHttpVersion protocol + | "0.9" `T.isSuffixOf` protocol = H.http09 + | "1.0" `T.isSuffixOf` protocol = H.http10 + | "1.1" `T.isSuffixOf` protocol = H.http11 + | "2.0" `T.isSuffixOf` protocol = H.http20 + | otherwise = H.http11 + +takeRequestBodyChunk :: MVar ByteString -> IO ByteString +takeRequestBodyChunk requestBodyMVar = do + result <- tryTakeMVar requestBodyMVar + case result of + Just bs -> pure bs + Nothing -> pure BS.empty + +toQueryStringParameters :: Maybe [(Text, Maybe Text)] -> [H.QueryItem] +toQueryStringParameters (Just params@(p:ps)) = + let toQueryItem (key, valueMay) = (encodeUtf8 key, encodeUtf8 <$> valueMay) + in map toQueryItem params +toQueryStringParameters _ = [] + +parseIp :: Maybe Text -> IO Socket.SockAddr +parseIp sourceIpText = + case sourceIpText of + Just sourceIp -> + case readMaybe (T.unpack sourceIp) of + Just ip -> + pure $ case ip of + IP.IPv4 ip4 -> + Socket.SockAddrInet + 0 -- default port + (IP.toHostAddress ip4) + IP.IPv6 ip6 -> + Socket.SockAddrInet6 + 0 -- default port + 0 -- flow info + (IP.toHostAddress6 ip6) + 0 -- scope id + Nothing -> error "Could not parse source ip." + Nothing -> error "Missing source ip." + +processRequest :: Application -> Wai.Request -> IO Wai.Response +processRequest app req = do + mvar <- newEmptyMVar + Wai.ResponseReceived <- app req $ \resp -> do + putMVar mvar resp + pure Wai.ResponseReceived + takeMVar mvar + +readResponse :: Wai.Response -> IO (H.Status, H.ResponseHeaders, ByteString) +readResponse (Wai.responseToStream -> (st, hdrs, mkBody)) = do + body <- mkBody drainBody + pure (st, hdrs, body) + where + drainBody :: Wai.StreamingBody -> IO ByteString + drainBody body = do + ioRef <- newIORef Binary.empty + body + (\b -> atomicModifyIORef ioRef (\b' -> (b <> b', ()))) + (pure ()) + BL.toStrict . Binary.toLazyByteString <$> readIORef ioRef + +wrapInResponse + :: Int + -> H.ResponseHeaders + -> res + -> ApiGatewayResponse res +wrapInResponse code responseHeaders response = + ApiGatewayResponse code responseHeaders response False + +toHeader :: (Text, Text) -> H.Header +toHeader (name, val) = (CI.mk . encodeUtf8 $ name, encodeUtf8 val) + +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"