diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/aws-lambda-runtime.cabal b/aws-lambda-runtime.cabal new file mode 100644 --- /dev/null +++ b/aws-lambda-runtime.cabal @@ -0,0 +1,77 @@ +cabal-version: 2.2 +name: aws-lambda-runtime +version: 0 + +synopsis: Haskell on AWS Lambda Runtime API +category: AWS, Development +description: + Make "native" Haskell AWS Lambda (using Runtime API). + . + * "AWS.Lambda.RuntimeAPI" is for writing lambdas + . + * "AWS.Lambda.RuntimeAPI.Package" is for packaging them. + +homepage: https://github.com/phadej/aws-lambda-haskell-runtime +bug-reports: https://github.com/phadej/aws-lambda-haskell-runtime/issues +license: Apache-2.0 +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg Grenrus +copyright: (c) 2018 Futurice, 2018 Oleg Grenrus + +tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.2 + +source-repository head + type: git + location: https://github.com/phadej/aws-lambda-haskell-runtime + +library + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + AWS.Lambda.RuntimeAPI + AWS.Lambda.RuntimeAPI.Package + + -- GHC boot libraries + build-depends: + , base ^>=4.10.1.0 || ^>=4.11.1.0 || ^>=4.12.0.0 + , bytestring ^>=0.10.8.2 + , containers ^>=0.5.10.2 || ^>= 0.6.0.1 + , deepseq ^>=1.4.3.0 + , text ^>=1.2.3.0 + , time ^>=1.8.0.2 + + -- other dependencies + build-depends: + , aeson ^>=1.4.2.0 + , async ^>=2.2.1 + , base-compat ^>=0.10.5 + , http-client ^>=0.5.14 + , http-media ^>=0.7.1.3 + , http-types ^>=0.12.2 + + -- for Package + build-depends: + , filepath ^>=1.4.1.2 + , parsec ^>=3.1.13.0 + , process ^>=1.6.1.0 + , zip-archive ^>=0.4 + +executable example-lambda + ghc-options: -Wall + hs-source-dirs: example + default-language: Haskell2010 + main-is: Example.hs + + -- inherited dependencies + build-depends: + , base + , aeson + , aws-lambda-runtime + , text + + -- additional dependencies + build-depends: + , lens ^>=4.17 + , lens-aeson ^>=1.0.2 diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,39 @@ +module Main where + +import AWS.Lambda.RuntimeAPI +import Control.Lens (deep, (%~), (&)) +import Data.Aeson (Value (..), decode) +import Data.String (fromString) +import Data.Aeson.Lens (_String) +import System.Environment (getArgs) + +import qualified Data.Text as T + +main :: IO () +main = autoMockJsonMain mock $ \req -> do + -- get remaining time (in millisecons) and log it + t <- getTimeRemaining req + print t + + let res :: Value + res = requestPayload req + & deep _String %~ T.toUpper + + return res + where + mock = Mock + { mockResponse = print + , mockRequest = do + args <- getArgs + case args of + -- no arguments: run with @null@ + [] -> mockRequest' Null + (a:_) + -- single argument: if looks like valid JSON: use it + | Just a' <- decode (fromString a) -> mockRequest' a' + -- otherwise pass as a literal string: + | otherwise -> mockRequest' (String (fromString a)) + } + + mockRequest' :: Value -> IO (GenRequest Value) + mockRequest' v = makeMockRequest v 10000 -- 10 seconds diff --git a/src/AWS/Lambda/RuntimeAPI.hs b/src/AWS/Lambda/RuntimeAPI.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeAPI.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Based on the logic as implemented in https://github.com/awslabs/aws-lambda-cpp +module AWS.Lambda.RuntimeAPI ( + -- * Entry points + defaultMain, + jsonMain, + -- ** Mocks + autoMockMain, + autoMockJsonMain, + Mock, GenMock (..), + makeMockRequest, + -- * Requests and response + Request, + Response (..), + GenRequest (..), + RequestId, + -- * Time remaining + getTimeRemaining, + -- * JSON responses + jsonResponse, + jsonMediaType, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent.Async (waitCatch, withAsync) +import Control.DeepSeq (NFData (..), force) +import Control.Exception (SomeException, displayException, evaluate) +import Control.Monad (forever, void) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Network.HTTP.Media (MediaType) +import System.Environment (lookupEnv) +import System.IO (hFlush, stdout) + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Time.Clock.System as Time +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Media as HTTP +import qualified Network.HTTP.Types as HTTP + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Opaque request id +newtype RequestId = RequestId ByteString + deriving Show + +newtype Deadline = Deadline Int64 + deriving Show + +-- | Request with 'ByteString' payload +type Request = GenRequest ByteString + +data GenRequest a = Request + { requestPayload :: !a -- ^ The user's payload represented (originally) as a UTF-8 string. + , requestId :: !RequestId -- ^ And identifier unique to the current invocation. + , requestXRayTraceId :: !ByteString -- ^ X-Ray tracigng of the current invocation. + , requestClientContext :: !ByteString -- ^ Information about the client application and device when invoked through the AWS Mobile SDK. + , requestCognitoIdentity :: !ByteString -- ^ Information about the Amazon Cognito identity provider when invoked through the AWS Mobile SDK. + , requestARN :: !ByteString -- ^ The ARN requested. This can be different in each invoke that executes the same version. + , requestDeadline :: !Deadline -- ^ Function execution deadline counted in milliseconds since the Unix epoch. + } + deriving (Show, Functor, Foldable, Traversable) + +data Response + = SuccessResponse !MediaType !BS.ByteString + | FailureResponse !Text !Text -- ^ error type, error message + deriving Show + +instance NFData Response where + rnf (SuccessResponse mt bs) = + rnf (HTTP.mainType mt) `seq` + rnf (HTTP.subType mt) `seq` + rnf (HTTP.parameters mt) `seq` + rnf bs + rnf (FailureResponse ty msg) = rnf msg `seq` rnf ty + +-- | Create JSON response. +jsonResponse :: Aeson.ToJSON a => a -> Response +jsonResponse a = SuccessResponse jsonMediaType $ LBS.toStrict $ Aeson.encode a + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +-- | Get time remaining (milliseconds). +getTimeRemaining :: GenRequest a -> IO Int64 +getTimeRemaining Request { requestDeadline = Deadline deadline } = do + millis <- getCurrentMillis + return (max 0 (deadline - millis)) + +-- | Get current time in milliseconds. Useful with 'Mock'. +getCurrentMillis :: IO Int64 +getCurrentMillis = do + Time.MkSystemTime sec nano <- Time.getSystemTime + return $ sec * 1000 + fromIntegral (nano `div` 1000000) + +------------------------------------------------------------------------------- +-- JSON media type +------------------------------------------------------------------------------- + +jsonMediaType :: MediaType +jsonMediaType = "application/json" + +------------------------------------------------------------------------------- +-- Logging +------------------------------------------------------------------------------- + +logError :: ByteString -> IO () +logError str = do + BS8.putStrLn $ "[ERROR] " <> str + hFlush stdout + +logException :: ByteString -> SomeException -> IO () +logException str exc = do + BS8.putStrLn $ "[ERROR] Exception " <> str <> " -- " <> BS8.pack (displayException exc) + hFlush stdout + +logInfo :: ByteString -> IO () +logInfo _ = return () + +logHttpRequest :: H.Request -> IO () +logHttpRequest _ = return () + +logHttpResponse :: HttpRes -> IO () +logHttpResponse _ = return () + +------------------------------------------------------------------------------- +-- Http +------------------------------------------------------------------------------- + +httpLbs :: Ctx -> H.Request -> IO HttpRes +httpLbs ctx req = do + logHttpRequest req + eres <- tryDeep $ toHttpRes <$> H.httpLbs req (ctxManager ctx) + case eres of + Right res -> do + logHttpResponse res + return res + Left exc -> do + logException "httpLbs" exc + return $ HttpRes + { hrStatus = HTTP.status500 + , hrHeaders = mempty + , hrBody = mempty + } + +data HttpRes = HttpRes + { hrStatus :: HTTP.Status + , hrHeaders :: HTTP.ResponseHeaders + , hrBody :: LBS.ByteString + } + +instance NFData HttpRes where + rnf (HttpRes (HTTP.Status x y) z w) = + rnf x `seq` + rnf y `seq` + rnf z `seq` + rnf w + +toHttpRes :: H.Response LBS.ByteString -> HttpRes +toHttpRes res = HttpRes + { hrStatus = H.responseStatus res + , hrHeaders = H.responseHeaders res + , hrBody = H.responseBody res + } + +------------------------------------------------------------------------------- +-- trydeep +------------------------------------------------------------------------------- + +-- | Erlang inspired tryDeep +tryDeep :: NFData a => IO a -> IO (Either SomeException a) +tryDeep m = withAsync (m >>= evaluate . force) waitCatch + +------------------------------------------------------------------------------- +-- Headers +------------------------------------------------------------------------------- + +headerRequestId :: HTTP.HeaderName +headerRequestId = "lambda-runtime-aws-request-id" + +headerTraceId :: HTTP.HeaderName +headerTraceId = "lambda-runtime-trace-id"; + +headerClientContext :: HTTP.HeaderName +headerClientContext = "lambda-runtime-client-context"; + +headerCognitoIdentity :: HTTP.HeaderName +headerCognitoIdentity = "lambda-runtime-cognito-identity"; + +headerARN :: HTTP.HeaderName +headerARN = "lambda-runtime-invoked-function-arn"; + +headerDeadline :: HTTP.HeaderName +headerDeadline = "lambda-runtime-deadline-ms"; + +------------------------------------------------------------------------------- +-- "runtime" +------------------------------------------------------------------------------- + +-- | Context. Called runtime in C++ implementation. +data Ctx = Ctx + { ctxManager :: H.Manager + , ctxNextRequest :: H.Request + , ctxSuccessRequest :: H.Request + , ctxErrorRequest :: H.Request + } + +-- | Initialise the context, i.e. needed things to communicate with AWS Lambda +initCtx :: IO Ctx +initCtx = do + endpoint <- do + e <- lookupEnv "AWS_LAMBDA_RUNTIME_API" + case e of + Nothing -> fail "AWS_LAMBDA_RUNTIME_API not defined" + Just e' -> return e' + + nextReq <- H.parseRequest $ "http://" ++ endpoint ++ "/2018-06-01/runtime/invocation/next" + successReq <- H.parseRequest $ "http://" ++ endpoint ++ "/2018-06-01/runtime/invocation/:request/response" + errorReq <- H.parseRequest $ "http://" ++ endpoint ++ "/2018-06-01/runtime/invocation/:request/error" + + mgr <- H.newManager H.defaultManagerSettings + -- TODO: I'm not sure if it's enought to have timeout only on NEXT requests? + { H.managerResponseTimeout = H.responseTimeoutNone + } + + return Ctx + { ctxManager = mgr + , ctxNextRequest = nextReq + -- { H.responseTimeout = H.responseTimeoutNone + -- } + , ctxSuccessRequest = successReq + { H.method = "POST" + } + , ctxErrorRequest = errorReq + { H.method = "POST" + } + } + +-- | Ask lambda for an invocation. +getNext :: Ctx -> IO (Either HTTP.Status Request) +getNext ctx = do + res <- httpLbs ctx $ ctxNextRequest ctx + + let st = hrStatus res + + if not $ HTTP.statusIsSuccessful st + then return (Left st) + else do + let headers = Map.fromList $ hrHeaders res + optionalHeader h = fromMaybe mempty $ Map.lookup h headers + + case Map.lookup headerRequestId headers of + Nothing -> return $ Left st + Just reqId -> return $ Right Request + { requestPayload = LBS.toStrict (hrBody res) + , requestId = RequestId reqId + , requestXRayTraceId = optionalHeader headerTraceId + , requestClientContext = optionalHeader headerClientContext + , requestCognitoIdentity = optionalHeader headerCognitoIdentity + , requestARN = optionalHeader headerARN + , requestDeadline = parseDeadline $ optionalHeader headerDeadline + } + where + parseDeadline bs = Deadline $ maybe 0 (fromInteger . fst) (BS8.readInteger bs) + +-- | Tells lambda that the function has succeeded. +postSuccess :: Ctx -> Request -> Response -> IO () +postSuccess ctx req (SuccessResponse mt bs) = + void $ httpLbs ctx httpReq + where + httpReq :: H.Request + httpReq = (ctxSuccessRequest ctx) + { H.path = replaceRequestId (requestId req) $ H.path (ctxSuccessRequest ctx) + , H.requestHeaders = + [ ("Content-Type", HTTP.renderHeader mt) + ] + , H.requestBody = H.RequestBodyBS bs + } +postSuccess ctx req (FailureResponse ty msg) = + postFailure ctx req ty msg + + +-- | Tells lambda that the function has failed. +postFailure :: Ctx -> Request -> Text -> Text -> IO () +postFailure ctx req ty msg = + void $ httpLbs ctx httpReq + where + httpReq :: H.Request + httpReq = (ctxSuccessRequest ctx) + { H.path = replaceRequestId (requestId req) $ H.path (ctxSuccessRequest ctx) + , H.requestHeaders = + [ ("Content-Type", HTTP.renderHeader jsonMediaType) + ] + , H.requestBody = H.RequestBodyLBS $ Aeson.encode $ Aeson.object + [ "errorMessage" Aeson..= msg + , "errorType" Aeson..= ty + , "stackTrace" Aeson..= Aeson.Array mempty + ] + } + +replaceRequestId :: RequestId -> ByteString -> ByteString +replaceRequestId (RequestId rid) path = case BS.breakSubstring ":request" path of + (pfx, sfx) -> pfx <> rid <> BS.drop 8 sfx + +------------------------------------------------------------------------------- +-- Main variants +------------------------------------------------------------------------------- + +-- | Default main to implement AWS Lambda using Runtime API +defaultMain :: (Request -> IO Response) -> IO () +defaultMain handler = do + ctx <- initCtx + + forever $ do + next <- getNext ctx + case next of + -- on failure we log, and loop + -- TODO: use status + Left _st -> logError "HTTP request was not successful. HTTP response code: %d. Retrying.." + + -- on success we have a request! + Right req -> do + logInfo "Invoking user handler" + eres <- tryDeep (handler req) + case eres of + Left exc -> do + logException "handler" exc + postFailure ctx req "SomeException" (Text.pack $ displayException exc) + Right res -> postSuccess ctx req res + +-- | Like 'defaultMain' but work with JSON +jsonMain :: (Aeson.FromJSON a, Aeson.ToJSON b) => (GenRequest a -> IO b) -> IO () +jsonMain handler = defaultMain $ \req -> + case traverse Aeson.eitherDecodeStrict req of + Right req' -> jsonResponse <$> handler req' + Left err -> return $ FailureResponse "decode" (Text.pack err) + +------------------------------------------------------------------------------- +-- Mock variants +------------------------------------------------------------------------------- + +type Mock = GenMock ByteString + +-- | How to mock the 'Request', what to do with the 'Response'. +data GenMock a = Mock + { mockRequest :: IO (GenRequest a) + , mockResponse :: Response -> IO () + } + +-- | Create 'Mock' request +makeMockRequest + :: a -- ^ payload value + -> Int64 -- ^ request duration (in milliseconds) + -> IO (GenRequest a) +makeMockRequest payload duration = do + currentMillis <- getCurrentMillis + return $ Request + { requestPayload = payload + , requestId = RequestId "mock-deadc0de" + , requestXRayTraceId = mempty + , requestClientContext = mempty + , requestCognitoIdentity = mempty + , requestARN = mempty + , requestDeadline = Deadline $ currentMillis + max 1000 duration + } + +-- | Check the existence of @AWS_LAMBDA_RUNTIME_API@ environment variable. +-- +-- If it exists, assume we are running in AWS Lambda environment, i.e. run normally. +-- Otherwise use supplied 'MockOptions' +autoMockMain :: Mock -> (Request -> IO Response) -> IO () +autoMockMain mock handler = do + e <- lookupEnv "AWS_LAMBDA_RUNTIME_API" + case e of + Just _ -> defaultMain handler + Nothing -> mockRequest mock >>= handler >>= mockResponse mock + +-- | Like 'autoMockMain' but works with JSON +autoMockJsonMain :: (Aeson.FromJSON a, Aeson.ToJSON b) => GenMock a -> (GenRequest a -> IO b) -> IO () +autoMockJsonMain mock handler = do + e <- lookupEnv "AWS_LAMBDA_RUNTIME_API" + case e of + Just _ -> jsonMain handler + Nothing -> mockRequest mock >>= handler >>= mockResponse mock . jsonResponse diff --git a/src/AWS/Lambda/RuntimeAPI/Package.hs b/src/AWS/Lambda/RuntimeAPI/Package.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeAPI/Package.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE MultiWayIf #-} +-- | Utility to package lambda +-- +-- Example usage, you need to run it on AWS Linux +-- (e.g. Docker, see [Dockerfile](https://github.com/phadej/aws-lambda-runtime-api/blob/master/docker-image/Dockerfile)) +-- with @GHC@, @cabal@ and @cabal-plan@ available. +-- +-- @ +-- module Main (main) where +-- +-- import AWS.Lambda.RuntimeAPI.Package ('defaultConf', 'packageAwsLambda') +-- import Data.Char (isSpace) +-- +-- import qualified Data.ByteString.Lazy as LBS +-- import qualified System.Process as P +-- +-- main :: IO () +-- main = do +-- -- Build the executable +-- let exe = "example-lambda" +-- P.callProcess "cabal" ["new-build", exe] +-- +-- -- Find the build artifact +-- exePath \<- trim \<$> P.readProcess "cabal-plan" [ "list-bin", exe ] "" +-- putStrLn $ "Packaging executable: " ++ exePath +-- +-- -- Package it +-- zipFile \<- 'packageAwsLambda' 'defaultConf' exePath +-- LBS.writeFile "example-lambda.zip" zipFile +-- where +-- trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse +-- @ +-- +-- Given such environment, we can build an example lambda function: +-- +-- @ +-- % docker run -ti --rm -v $(pwd):/work -w /work amazonlinux-with-ghc +-- +-- % cabal new-update +-- % cabal new-build +-- % runghc package-example-lambda.hs +-- @ +-- +-- The resulting @example-lambda.zip@ is ready to be uploaded! +-- +module AWS.Lambda.RuntimeAPI.Package ( + packageAwsLambda, + Conf (..), + defaultConf, + confAdditionalLibs, + confReadFile, + -- * Utilities + findExtraLibs, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Applicative (Alternative (..), optional) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Bits (shiftL) +import Data.Char (isAlphaNum, isHexDigit) +import Data.List (isPrefixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes) +import Data.Traversable (for) +import System.FilePath.Posix (takeFileName) +import System.Process (proc, readCreateProcess) + +import qualified Codec.Archive.Zip as Zip +import qualified Data.ByteString.Lazy as LBS +import qualified Text.Parsec as P + +-- | Package AWS Lambda executable. +packageAwsLambda + :: Conf + -> FilePath + -> IO LBS.ByteString -- ^ Result is ZIP package +packageAwsLambda conf exePath = do + -- executable, we package it as "bootstrap" + exeContents <- _confReadFile conf exePath + + let exeEntry :: Zip.Entry + exeEntry = (Zip.toEntry "bootstrap" 0 exeContents) + { Zip.eExternalFileAttributes = shiftL 0755 16 + , Zip.eVersionMadeBy = 0x0300 -- UNIX file attributes + } + + -- .so dependencies + libs <- findExtraLibs (_confAdditionalLibs conf) exePath + libEntries <- for libs $ \lib -> do + libContents <- _confReadFile conf lib + return $ Zip.toEntry (takeFileName lib) 0 libContents + + -- all together + let entries = exeEntry : libEntries + + evaluate $ force $ Zip.fromArchive Zip.Archive + { Zip.zEntries = entries + , Zip.zSignature = Nothing + , Zip.zComment = mempty + } + +data Conf = Conf + { _confAdditionalLibs :: ![String] -- ^ library names we know surely need to be packaged + , _confReadFile :: !(FilePath -> IO LBS.ByteString) -- ^ function to read file from filesystem + } + +defaultConf :: Conf +defaultConf = Conf + { _confAdditionalLibs = [] + , _confReadFile = LBS.readFile + } + +confAdditionalLibs :: Functor f => ([String] -> f [String]) -> Conf -> f Conf +confAdditionalLibs f conf = (\x -> conf { _confAdditionalLibs = x}) <$> f (_confAdditionalLibs conf) + +confReadFile :: Functor f => ((FilePath -> IO LBS.ByteString) -> f (FilePath -> IO LBS.ByteString)) -> Conf -> f Conf +confReadFile f conf = (\x -> conf { _confReadFile = x}) <$> f (_confReadFile conf) + +------------------------------------------------------------------------------- +-- LDD magic - find dependencies +------------------------------------------------------------------------------- + +-- | Run @ldd@ on given @filepath@, return @.so@ files. +findExtraLibs + :: [String] -- ^ additional libs + -> FilePath -- ^ ELF file + -> IO [FilePath] +findExtraLibs additionalCopyLibs fp = do + output <- readCreateProcess (proc "ldd" [fp]) "" + either (fail . show) (return . catMaybes) $ + P.parse (many lddLine <* P.eof) "" output + where + lddLine = do + P.spaces + lib <|> ldLinux + + lib = do + l :| _ <- sepByNonEmpty + (some $ P.satisfy $ \c -> isAlphaNum c || c == '-' || c == '+' || c == '_') + (P.char '.') + + P.spaces + md <- optional $ do + _ <- P.string "=>" + P.spaces + many $ P.satisfy $ \c -> + isAlphaNum c || c == '.' || c == '-' || c == '+' || c == '_' || c == '/' + _ <- address + + if | "libHS" `isPrefixOf` l -> return md + | l `elem` skipLibs -> return Nothing + | l `elem` copyLibs -> return md + | otherwise -> fail $ "Unknown lib " ++ l + + ldLinux = P.string "/lib64/ld-linux-x86-64.so.2" *> address *> return Nothing + + sepByNonEmpty p sep = do + x <- p + xs <- many (sep *> p) + return (x :| xs) + + -- Libraries which exist in Linux AMI + skipLibs = + [ "linux-vdso" + + , "libBrokenLocale" + , "libacl" + , "libanl" + , "libasound" + , "libattr" + , "libaudit" + , "libauparse" + , "libblkid" + , "libbz2" + , "libc" + , "libcap-ng" + , "libcap" + , "libcidn" + , "libcrypt" + -- , "libcrypto" + , "libdbus-1" + , "libdl" + , "libexpat" + , "libgcc_s-4.8.3-20140911" + , "libgcc_s" + , "libgpg-error" + , "libidn" + , "libip4tc" + , "libip6tc" + , "libiptc" + , "libkeyutils" + , "liblber-2.4" + , "libldap-2.4" + , "libldap_r-2.4" + , "libldif-2.4" + , "libm" + , "libmount" + , "libncurses" + , "libncursesw" + , "libnih-dbus" + , "libnih" + , "libnsl" + , "libnss_compat" + , "libnss_db" + , "libnss_dns" + , "libnss_files" + , "libnss_hesiod" + , "libnss_nis" + , "libnss_nisplus" + , "libpam" + , "libpam_misc" + , "libpamc" + , "libpcre" + , "libpopt" + , "libpthread" + , "libpwquality" + , "libreadline" + , "libresolv" + , "librt" + , "libsepol" + , "libthread_db" + , "libtinfo" + , "libudev" + , "libutil" + , "libuuid" + , "libxtables" + , "libz" + + ] + + -- Libraries which we know for sure aren't in Amazon Linux AMI + copyLibs = + [ "libgmp" + , "libffi" + ] ++ additionalCopyLibs + + address = P.spaces + *> P.char '(' + *> P.string "0x" + *> P.skipMany (P.satisfy isHexDigit) + *> P.char ')' + *> P.char '\n'