aws-lambda-haskell-runtime-wai (empty) → 1.0.0

raw patch · 7 files changed

+321/−0 lines, 7 filesdep +aesondep +aws-lambda-haskell-runtimedep +aws-lambda-haskell-runtime-waisetup-changed

Dependencies added: aeson, aws-lambda-haskell-runtime, aws-lambda-haskell-runtime-wai, base, binary, bytestring, case-insensitive, http-types, iproute, network, text, unordered-containers, vault, wai

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +28/−0
Setup.hs +2/−0
aws-lambda-haskell-runtime-wai.cabal +76/−0
src/Aws/Lambda/Wai.hs +180/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for aws-lambda-haskell-runtime-wai++## Unreleased changes

+ LICENSE view

@@ -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.

+ README.md view

@@ -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 }+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ aws-lambda-haskell-runtime-wai.cabal view

@@ -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 <https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai#readme>+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

+ src/Aws/Lambda/Wai.hs view

@@ -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

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"