Skip to content

Commit 55f9b4f

Browse files
dnikolovvdnikolovv
authored
Merge pull request #8 from eir-forsakring/runtime-v4
Runtime v4
2 parents ad97010 + 5cd086c commit 55f9b4f

File tree

6 files changed

+194
-53
lines changed

6 files changed

+194
-53
lines changed

Diff for: ‎aws-lambda-haskell-runtime-wai.cabal

+5-4
Original file line numberDiff line numberDiff line change
@@ -4,10 +4,10 @@ cabal-version: 1.12
44
--
55
-- see: https://github.com/sol/hpack
66
--
7-
-- hash: b058fdb06a583f8a099ddb363fe357b8c7b8691b7f4381b3dbc99b02003c5add
7+
-- hash: db26d2a6844a72b8bdcec7bed0d2a1c73a680da0b0311931746f4993ac9a434a
88

99
name: aws-lambda-haskell-runtime-wai
10-
version: 1.0.3
10+
version: 2.0.0
1111
synopsis: Run wai applications on AWS Lambda
1212
description: Please see the README on GitHub at <https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai#readme>
1313
category: AWS
@@ -34,9 +34,10 @@ library
3434
Paths_aws_lambda_haskell_runtime_wai
3535
hs-source-dirs:
3636
src
37+
ghc-options: -Werror -Wall
3738
build-depends:
3839
aeson
39-
, aws-lambda-haskell-runtime >=3.0.4
40+
, aws-lambda-haskell-runtime >=4.0.0
4041
, base >=4.7 && <5
4142
, binary
4243
, bytestring
@@ -60,7 +61,7 @@ test-suite aws-lambda-haskell-runtime-wai-test
6061
ghc-options: -threaded -rtsopts -with-rtsopts=-N
6162
build-depends:
6263
aeson
63-
, aws-lambda-haskell-runtime >=3.0.4
64+
, aws-lambda-haskell-runtime >=4.0.0
6465
, aws-lambda-haskell-runtime-wai
6566
, base >=4.7 && <5
6667
, binary

Diff for: ‎hie.yaml

+7
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
cradle:
2+
stack:
3+
- path: "./src"
4+
component: "aws-lambda-haskell-runtime-wai:lib"
5+
6+
- path: "./test"
7+
component: "aws-lambda-haskell-runtime-wai:test:aws-lambda-haskell-runtime-wai-test"

Diff for: ‎package.yaml

+5-2
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: aws-lambda-haskell-runtime-wai
2-
version: 1.0.3
2+
version: 2.0.0
33
github: "eir-forsakring/aws-lambda-haskell-runtime-wai"
44
license: BSD3
55
author: "Dobromir Nikolov"
@@ -21,7 +21,7 @@ description: Please see the README on GitHub at <https://github.com/eir-
2121

2222
dependencies:
2323
- base >= 4.7 && < 5
24-
- aws-lambda-haskell-runtime >= 3.0.4
24+
- aws-lambda-haskell-runtime >= 4.0.0
2525
- bytestring
2626
- text
2727
- binary
@@ -36,6 +36,9 @@ dependencies:
3636

3737
library:
3838
source-dirs: src
39+
ghc-options:
40+
- -Werror
41+
- -Wall
3942

4043
tests:
4144
aws-lambda-haskell-runtime-wai-test:

Diff for: ‎src/Aws/Lambda/Wai.hs

+167-37
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,27 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE RecordWildCards #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
4-
{-# LANGUAGE StandaloneDeriving #-}
4+
{-# LANGUAGE TypeApplications #-}
55
{-# LANGUAGE ViewPatterns #-}
66

7-
module Aws.Lambda.Wai (waiHandler, waiHandler', WaiHandler) where
7+
module Aws.Lambda.Wai
8+
( runWaiAsLambda,
9+
runWaiAsProxiedHttpLambda,
10+
WaiLambdaProxyType (..),
11+
apiGatewayWaiHandler,
12+
ApiGatewayWaiHandler,
13+
albWaiHandler,
14+
ALBWaiHandler,
15+
ignoreALBPathPart,
16+
ignoreNothing,
17+
)
18+
where
819

920
import Aws.Lambda
1021
import Control.Concurrent.MVar
1122
import Data.Aeson
12-
import qualified Data.Aeson as Aeson
13-
import qualified Data.Aeson.Types as Aeson
23+
import Data.Aeson.Types
24+
import Data.Bifunctor (Bifunctor (bimap))
1425
import qualified Data.Binary.Builder as Binary
1526
import Data.ByteString (ByteString)
1627
import qualified Data.ByteString as BS
@@ -25,41 +36,171 @@ import qualified Data.Text as T
2536
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
2637
import qualified Data.Text.Encoding as T
2738
import qualified Data.Vault.Lazy as Vault
28-
import GHC.IO.Unsafe (unsafePerformIO)
2939
import qualified Network.HTTP.Types as H
3040
import qualified Network.Socket as Socket
3141
import Network.Wai (Application)
3242
import qualified Network.Wai as Wai
3343
import qualified Network.Wai.Internal as Wai
44+
import qualified System.IO as IO
3445
import Text.Read (readMaybe)
3546

36-
type WaiHandler context = ApiGatewayRequest Text -> Context context -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
47+
type ApiGatewayWaiHandler = ApiGatewayRequest Text -> Context Application -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
3748

38-
waiHandler :: forall context. IO Wai.Application -> WaiHandler context
39-
waiHandler initApp gatewayRequest context =
40-
initApp
41-
>>= \app -> waiHandler'' app gatewayRequest context
49+
type ALBWaiHandler = ALBRequest Text -> Context Application -> IO (Either (ALBResponse Text) (ALBResponse Text))
4250

43-
waiHandler' :: forall context. (context -> Wai.Application) -> WaiHandler context
44-
waiHandler' getApp request context = do
45-
app <- getApp <$> readIORef (customContext context)
46-
waiHandler'' app request context
51+
newtype ALBIgnoredPathPortion = ALBIgnoredPathPortion {unALBIgnoredPathPortion :: Text}
4752

48-
waiHandler'' :: forall context. Wai.Application -> WaiHandler context
49-
waiHandler'' waiApplication gatewayRequest _ = do
50-
waiRequest <- mkWaiRequest gatewayRequest
53+
data WaiLambdaProxyType
54+
= APIGateway
55+
| ALB (Maybe ALBIgnoredPathPortion)
56+
57+
runWaiAsProxiedHttpLambda ::
58+
DispatcherOptions ->
59+
Maybe ALBIgnoredPathPortion ->
60+
HandlerName ->
61+
IO Application ->
62+
IO ()
63+
runWaiAsProxiedHttpLambda options ignoredAlbPath handlerName mkApp =
64+
runLambdaHaskellRuntime options mkApp id $
65+
addStandaloneLambdaHandler handlerName $ \(request :: Value) context ->
66+
case parse parseIsAlb request of
67+
Success isAlb -> do
68+
if isAlb
69+
then case fromJSON @(ALBRequest Text) request of
70+
Success albRequest ->
71+
bimap toJSON toJSON <$> albWaiHandler ignoredAlbPath albRequest context
72+
Error err -> error $ "Could not parse the request as a valid ALB request: " <> err
73+
else case fromJSON @(ApiGatewayRequest Text) request of
74+
Success apiGwRequest ->
75+
bimap toJSON toJSON <$> apiGatewayWaiHandler apiGwRequest context
76+
Error err -> error $ "Could not parse the request as a valid API Gateway request: " <> err
77+
Error err ->
78+
error $
79+
"Could not parse the request as a valid API Gateway or ALB proxy request: " <> err
80+
where
81+
parseIsAlb :: Value -> Parser Bool
82+
parseIsAlb = withObject "Request" $ \obj -> do
83+
requestContextMay <- obj .:? "requestContext"
84+
case requestContextMay of
85+
Just requestContext -> do
86+
elb <- requestContext .:? "elb"
87+
case elb of
88+
Just (_ :: Value) -> pure True
89+
Nothing -> pure False
90+
Nothing -> pure False
91+
92+
runWaiAsLambda ::
93+
WaiLambdaProxyType ->
94+
DispatcherOptions ->
95+
HandlerName ->
96+
IO Application ->
97+
IO ()
98+
runWaiAsLambda proxyType options handlerName mkApp = do
99+
case proxyType of
100+
APIGateway -> do
101+
IO.print $ "Starting Lambda using API gateway handler '" <> unHandlerName handlerName <> "'."
102+
runLambdaHaskellRuntime options mkApp id $ do
103+
addAPIGatewayHandler handlerName apiGatewayWaiHandler
104+
(ALB ignoredPath) -> do
105+
IO.print $ "Starting Lambda using ALB handler '" <> unHandlerName handlerName <> "'."
106+
runLambdaHaskellRuntime options mkApp id $ do
107+
addALBHandler handlerName (albWaiHandler ignoredPath)
108+
109+
ignoreALBPathPart :: Text -> Maybe ALBIgnoredPathPortion
110+
ignoreALBPathPart = Just . ALBIgnoredPathPortion
111+
112+
ignoreNothing :: Maybe ALBIgnoredPathPortion
113+
ignoreNothing = Nothing
114+
115+
albWaiHandler :: Maybe ALBIgnoredPathPortion -> ALBWaiHandler
116+
albWaiHandler ignoredPathPortion request context = do
117+
waiApplication <- readIORef (customContext context)
118+
waiRequest <- mkWaiRequestFromALB ignoredPathPortion request
119+
120+
(status, headers, body) <- processRequest waiApplication waiRequest >>= readResponse
121+
122+
if BS.null body
123+
then return . pure . mkALBResponse (H.statusCode status) headers $ mempty
124+
else case decodeUtf8' body of
125+
Right responseBodyText ->
126+
return . pure . mkALBResponse (H.statusCode status) headers $ responseBodyText
127+
Left err -> error $ "Expected a response body that is valid UTF-8: " <> show err
128+
129+
apiGatewayWaiHandler :: ApiGatewayWaiHandler
130+
apiGatewayWaiHandler request context = do
131+
waiApplication <- readIORef (customContext context)
132+
waiRequest <- mkWaiRequestFromApiGw request
51133

52134
(status, headers, body) <- processRequest waiApplication waiRequest >>= readResponse
53135

54136
if BS.null body
55-
then return . pure . wrapInResponse (H.statusCode status) headers $ mempty
137+
then return . pure . mkApiGatewayResponse (H.statusCode status) headers $ mempty
56138
else case decodeUtf8' body of
57139
Right responseBodyText ->
58-
return . pure . wrapInResponse (H.statusCode status) headers $ responseBodyText
59-
Left err -> error "Expected a response body that is valid UTF-8."
140+
return . pure . mkApiGatewayResponse (H.statusCode status) headers $ responseBodyText
141+
Left err -> error $ "Expected a response body that is valid UTF-8: " <> show err
142+
143+
mkWaiRequestFromALB :: Maybe ALBIgnoredPathPortion -> ALBRequest Text -> IO Wai.Request
144+
mkWaiRequestFromALB (fmap unALBIgnoredPathPortion -> pathPortionToIgnore) ALBRequest {..} = do
145+
let sourceIpMay = albRequestHeaders >>= HMap.lookup "x-forwarded-for"
146+
147+
ip <- parseIp sourceIpMay
148+
149+
let requestPath =
150+
case pathPortionToIgnore of
151+
Just toIgnore ->
152+
let toIgnoreSafe = "/" <> T.dropWhile (\c -> c == '/' || c == '\\') toIgnore
153+
throwPathError =
154+
error $
155+
"Given path piece to ignore '"
156+
<> T.unpack toIgnoreSafe
157+
<> "' is longer than the received request path "
158+
<> T.unpack albRequestPath
159+
<> "!"
160+
in fromMaybe throwPathError $ T.stripPrefix toIgnoreSafe albRequestPath
161+
Nothing -> albRequestPath
162+
163+
-- TODO: Duplication
164+
let pathInfo = H.decodePathSegments (encodeUtf8 requestPath)
165+
166+
let requestBodyRaw = maybe mempty T.encodeUtf8 albRequestBody
167+
let requestBodyLength = Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw
168+
169+
requestBodyMVar <- newMVar requestBodyRaw
170+
171+
let requestBody = takeRequestBodyChunk requestBodyMVar
172+
let headers = fromMaybe HMap.empty albRequestHeaders
173+
let requestHeaderHost = encodeUtf8 <$> HMap.lookup "host" headers
174+
let requestHeaderRange = encodeUtf8 <$> HMap.lookup "range" headers
175+
let requestHeaderReferer = encodeUtf8 <$> HMap.lookup "referer" headers
176+
let requestHeaderUserAgent = encodeUtf8 <$> HMap.lookup "User-Agent" headers
177+
178+
let queryParameters = toQueryStringParameters albRequestQueryStringParameters
179+
rawQueryString = H.renderQuery True queryParameters
180+
httpVersion = H.http11 -- ALB converts even HTTP/2 requests to 1.1
181+
let result =
182+
Wai.Request
183+
(encodeUtf8 albRequestHttpMethod)
184+
httpVersion
185+
(encodeUtf8 requestPath)
186+
rawQueryString
187+
(map toHeader $ HMap.toList headers)
188+
True -- We assume it's always secure as we're passing through API Gateway
189+
ip
190+
pathInfo
191+
queryParameters
192+
requestBody
193+
Vault.empty
194+
requestBodyLength
195+
requestHeaderHost
196+
requestHeaderRange
197+
requestHeaderReferer
198+
requestHeaderUserAgent
199+
200+
return result
60201

61-
mkWaiRequest :: ApiGatewayRequest Text -> IO Wai.Request
62-
mkWaiRequest ApiGatewayRequest {..} = do
202+
mkWaiRequestFromApiGw :: ApiGatewayRequest Text -> IO Wai.Request
203+
mkWaiRequestFromApiGw ApiGatewayRequest {..} = do
63204
let ApiGatewayRequestContext {..} = apiGatewayRequestRequestContext
64205
ApiGatewayRequestContextIdentity {..} = apiGatewayRequestContextIdentity
65206

@@ -70,9 +211,9 @@ mkWaiRequest ApiGatewayRequest {..} = do
70211
-- includes the resource which we don't need
71212
case apiGatewayRequestPathParameters of
72213
Just pathParametersMap ->
73-
case HMap.lookup "proxy" pathParametersMap of
74-
Just proxyPath -> proxyPath
75-
Nothing -> apiGatewayRequestPath
214+
fromMaybe
215+
apiGatewayRequestPath
216+
(HMap.lookup "proxy" pathParametersMap)
76217
Nothing -> apiGatewayRequestPath
77218

78219
let pathInfo = H.decodePathSegments (encodeUtf8 requestPath)
@@ -176,16 +317,5 @@ readResponse (Wai.responseToStream -> (st, hdrs, mkBody)) = do
176317
(pure ())
177318
BL.toStrict . Binary.toLazyByteString <$> readIORef ioRef
178319

179-
wrapInResponse ::
180-
Int ->
181-
H.ResponseHeaders ->
182-
res ->
183-
ApiGatewayResponse res
184-
wrapInResponse code responseHeaders response =
185-
ApiGatewayResponse code responseHeaders response False
186-
187320
toHeader :: (Text, Text) -> H.Header
188-
toHeader (name, val) = (CI.mk . encodeUtf8 $ name, encodeUtf8 val)
189-
190-
tshow :: Show a => a -> Text
191-
tshow = T.pack . show
321+
toHeader (name, val) = (CI.mk . encodeUtf8 $ name, encodeUtf8 val)

Diff for: ‎stack.yaml

+2-2
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@
1717
#
1818
# resolver: ./custom-snapshot.yaml
1919
# resolver: https://example.com/snapshots/2018-01-01.yaml
20-
resolver: lts-15.16
20+
resolver: lts-16.12
2121

2222
# User packages to be built.
2323
# Various formats can be used as shown in the example below.
@@ -40,7 +40,7 @@ packages:
4040
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
4141
#
4242
extra-deps:
43-
- aws-lambda-haskell-runtime-3.0.4
43+
- aws-lambda-haskell-runtime-4.0.1@sha256:325704979a6e2be21dac89acaa6a159fbea4dd2ce1f022860abcfbac3f41a7de,2916
4444
# Override default flag values for local packages and extra-deps
4545
# flags: {}
4646

Diff for: ‎stack.yaml.lock

+8-8
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,15 @@
55

66
packages:
77
- completed:
8-
hackage: aws-lambda-haskell-runtime-3.0.4@sha256:1cf55a477befe5084bf1600c78f57784b6f94735cf3cfb5f13d1fcfd88b57547,3015
8+
hackage: aws-lambda-haskell-runtime-4.0.1@sha256:325704979a6e2be21dac89acaa6a159fbea4dd2ce1f022860abcfbac3f41a7de,2916
99
pantry-tree:
10-
size: 1560
11-
sha256: 51b6043b373e5260b2e37b48cd0104af9d327a0244dfa0d9f6e2d5a45a600035
10+
size: 1453
11+
sha256: 489fe49e75d19b7e4a298b246dcea3c48dfac8d73611a1715222e94a64fd3129
1212
original:
13-
hackage: aws-lambda-haskell-runtime-3.0.4
13+
hackage: aws-lambda-haskell-runtime-4.0.1@sha256:325704979a6e2be21dac89acaa6a159fbea4dd2ce1f022860abcfbac3f41a7de,2916
1414
snapshots:
1515
- completed:
16-
size: 496120
17-
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/16.yaml
18-
sha256: cf30623a2c147f51eecc8f9d6440f5d1b671af21380505e633faff32b565f3d5
19-
original: lts-15.16
16+
size: 532377
17+
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/12.yaml
18+
sha256: f914cfa23fef85bdf895e300a8234d9d0edc2dbec67f4bc9c53f85867c50eab6
19+
original: lts-16.12

0 commit comments

Comments
 (0)