diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,13 @@ -Copyright Author name here (c) 2018 - -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. +Copyright 2018 The Agile Monkeys - * 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. +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 - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + http://www.apache.org/licenses/LICENSE-2.0 -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. +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/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,54 @@ # Haskell Runtime for AWS Lambda +[![Hackage](https://img.shields.io/hackage/v/aws-lambda-haskell-runtime.svg)](https://hackage.haskell.org/package/aws-lambda-haskell-runtime) +[![Linter](https://img.shields.io/badge/code%20style-HLint-brightgreen.svg)](https://github.com/ndmitchell/hlint) +[![CircleCI](https://circleci.com/gh/theam/aws-lambda-haskell-runtime/tree/master.svg?style=svg)](https://circleci.com/gh/theam/aws-lambda-haskell-runtime/tree/master) + This package provides a way of running Haskell projects on AWS Lambda. + +## Sample lambda function + +``` +stack new my-haskell-lambda https://github.com/theam/aws-lambda-haskell-runtime/raw/master/stack-template.hsfiles --resolver=lts-12.13 --omit-packages +cd my-haskell-lambda +stack docker pull +``` + +Then add + +``` +packages: +- . + +extra-deps: +- aws-lambda-haskell-runtime-1.0.4 +``` + +to your `stack.yaml` + +Then run + +``` +make +``` + +Now you should have a `build/function.zip` file that you can upload to your lambda. + +## Lambda function configuration + +When creating your lambda function you need to provide a layer with the Haskell runtime. We have deployed the layer to our AWS account, you can use it or deploy it to your own AWS account. + +The ARN of the runtime layer is: +``` +arn:aws:lambda::785355572843:layer:haskell-runtime: +```` + +The version of the layer may be different depending of the region, the current values are: + +| us-east-2 | Other regions | +|-----------|---------------| +| 10 | 2 | + +## Full user guide + +Take a look at the [Getting Started with the Haskell AWS Lambda Runtime](https://medium.com/the-theam-journey/getting-started-with-the-haskell-aws-lambda-runtime-951b2322c7a3) guide. diff --git a/aws-lambda-haskell-runtime.cabal b/aws-lambda-haskell-runtime.cabal --- a/aws-lambda-haskell-runtime.cabal +++ b/aws-lambda-haskell-runtime.cabal @@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack -- --- hash: eb0c1a0fc5528fcd3765757dd2c1e92a71d28843c032385383b0cd05e2ca1f58 +-- hash: 2ef45c75a139565b825b94e2a0dfb5a1ba2cb921f85ce064de99be29e2c60cfb name: aws-lambda-haskell-runtime -version: 1.0.4 +version: 1.0.5 synopsis: Haskell runtime for AWS Lambda -description: Please see the README on GitHub at +description: Please see the README on GitHub at category: AWS homepage: https://github.com/theam/aws-lambda-haskell-runtime#readme bug-reports: https://github.com/theam/aws-lambda-haskell-runtime/issues @@ -53,6 +53,7 @@ , relude , template-haskell , text + , uuid , wreq default-language: Haskell2010 @@ -65,22 +66,9 @@ default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables NoImplicitPrelude DeriveGeneric TypeApplications ghc-options: -Wall -optP-Wno-nonportable-include-path build-depends: - aeson - , aws-lambda-haskell-runtime + aws-lambda-haskell-runtime , base >=4.7 && <5 - , bytestring - , case-insensitive - , conduit - , directory - , filepath - , microlens-platform - , mtl - , optparse-generic - , process , relude - , template-haskell - , text - , wreq default-language: Haskell2010 test-suite aws-lambda-haskell-runtime-test @@ -93,22 +81,7 @@ default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables NoImplicitPrelude DeriveGeneric TypeApplications ghc-options: -Wall -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck - , aeson - , aws-lambda-haskell-runtime - , base >=4.7 && <5 - , bytestring - , case-insensitive - , conduit - , directory - , filepath + base >=4.7 && <5 , hspec - , microlens-platform - , mtl - , optparse-generic - , process , relude - , template-haskell - , text - , wreq default-language: Haskell2010 diff --git a/src/Aws/Lambda/Configuration.hs b/src/Aws/Lambda/Configuration.hs --- a/src/Aws/Lambda/Configuration.hs +++ b/src/Aws/Lambda/Configuration.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-} module Aws.Lambda.Configuration ( LambdaOptions (..) , configureLambda @@ -18,6 +19,7 @@ import qualified System.Directory as Directory import System.FilePath (()) import System.IO.Error +import System.IO (hFlush) import Aws.Lambda.ThHelpers @@ -26,10 +28,12 @@ { eventObject :: Text , contextObject :: Text , functionHandler :: Text + , executionUuid :: Text } deriving (Generic) instance Options.ParseRecord LambdaOptions +-- This function is the reason why we disable the warning on top of the module mkMain :: Q [Dec] mkMain = [d| $(pName "main") = getRecord "" >>= run @@ -38,7 +42,7 @@ mkRun :: Q Dec mkRun = do handlers <- runIO getHandlers - clause' <- recordQ "LambdaOptions" ["functionHandler", "contextObject", "eventObject"] + clause' <- recordQ "LambdaOptions" ["functionHandler", "contextObject", "eventObject", "executionUuid"] body <- dispatcherCaseQ handlers pure $ FunD (mkName "run") [Clause [clause'] (NormalB body) []] @@ -56,7 +60,7 @@ let pattern = LitP (StringL $ toString lambdaHandler) body <- [e|do result <- $(eName qualifiedName) (decodeObj $(eName "eventObject")) (decodeObj $(eName "contextObject")) - either returnAndFail returnAndSucceed result + either (returnAndFail $(eName "executionUuid")) (returnAndSucceed $(eName "executionUuid")) result |] pure $ Match pattern (NormalB body) [] where @@ -71,7 +75,7 @@ unmatchedCaseQ = do let pattern = WildP body <- [e| - returnAndFail ("Handler " <> $(eName "functionHandler") <> " does not exist on project") + returnAndFail $(eName "executionUuid") ("Handler " <> $(eName "functionHandler") <> " does not exist on project") |] pure $ Match pattern (NormalB body) [] @@ -82,29 +86,41 @@ return $ main <> [run] -returnAndFail :: ToJSON a => a -> IO () -returnAndFail v = do - putTextLn (decodeUtf8 $ encode v) - exitFailure +returnAndFail :: ToJSON a => Text -> a -> IO () +returnAndFail uuid v = do + hFlush stdout + putTextLn uuid + hFlush stdout + putTextLn (decodeUtf8 $ encode v) + hFlush stdout + hFlush stderr + exitFailure -returnAndSucceed :: ToJSON a => a -> IO () -returnAndSucceed v = do - putTextLn (decodeUtf8 $ encode v) - exitSuccess +returnAndSucceed :: ToJSON a => Text -> a -> IO () +returnAndSucceed uuid v = do + hFlush stdout + putTextLn uuid + hFlush stdout + putTextLn (decodeUtf8 $ encode v) + hFlush stdout + exitSuccess decodeObj :: FromJSON a => Text -> a -decodeObj x = (decode $ encodeUtf8 x) ?: error $ "Could not decode event " <> x +decodeObj x = + case (eitherDecode $ encodeUtf8 x) of + Left e -> error $ toText e + Right v -> v data DirContent = DirList [FilePath] [FilePath] | DirError IOError data DirData = DirData FilePath DirContent -- Produces directory data -walk :: FilePath -> Conduit.Source IO DirData +walk :: FilePath -> Conduit.ConduitT () DirData IO () walk path = do result <- lift $ tryIOError listdir case result of - Right dl@(DirList subdirs files) -> do + Right dl@(DirList subdirs _) -> do Conduit.yield (DirData path dl) forM_ subdirs (walk . (path )) Right e -> Conduit.yield (DirData path e) @@ -122,14 +138,14 @@ -- Consume directories -myVisitor :: Conduit.Sink DirData IO [FilePath] +myVisitor :: Conduit.ConduitT DirData Void IO [FilePath] myVisitor = loop [] where loop n = do r <- Conduit.await case r of Nothing -> return n - Just r -> loop (process r <> n) + Just result -> loop (process result <> n) process (DirData _ (DirError _)) = [] process (DirData dir (DirList _ files)) = map (\f -> dir <> "/" <> f) files diff --git a/src/Aws/Lambda/Runtime.hs b/src/Aws/Lambda/Runtime.hs --- a/src/Aws/Lambda/Runtime.hs +++ b/src/Aws/Lambda/Runtime.hs @@ -11,6 +11,9 @@ import qualified Network.Wreq as Wreq import qualified System.Environment as Environment import qualified System.Process as Process +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import System.IO (hFlush) type App a = @@ -71,6 +74,30 @@ LambdaResult Text +awsLambdaVersion :: String +awsLambdaVersion = "2018-06-01" + + +nextInvocationEndpoint :: Text -> String +nextInvocationEndpoint endpoint = + "http://" <> toString endpoint <> "/"<> awsLambdaVersion <>"/runtime/invocation/next" + + +responseEndpoint :: Text -> Text -> String +responseEndpoint lambdaApi requestId = + "http://"<> toString lambdaApi <> "/" <> awsLambdaVersion <> "/runtime/invocation/"<> toString requestId <> "/response" + + +invocationErrorEndpoint :: Text -> Text -> String +invocationErrorEndpoint lambdaApi requestId = + "http://"<> toString lambdaApi <> "/" <> awsLambdaVersion <> "/runtime/invocation/"<> toString requestId <> "/error" + + +runtimeInitErrorEndpoint :: Text -> String +runtimeInitErrorEndpoint lambdaApi = + "http://"<> toString lambdaApi <> "/" <> awsLambdaVersion <> "/runtime/init/error" + + readEnvironmentVariable :: Text -> App Text readEnvironmentVariable envVar = do v <- lift (Environment.lookupEnv $ toString envVar) @@ -91,22 +118,14 @@ getApiData :: Text -> App (Wreq.Response LByteString) getApiData endpoint = - tryIO (Wreq.get nextInvocationEndpoint) + keepRetrying (Wreq.get $ nextInvocationEndpoint endpoint) where - nextInvocationEndpoint :: String - nextInvocationEndpoint = - "http://" <> toString endpoint <> "/2018-06-01/runtime/invocation/next" - - tryIO :: IO a -> App a - tryIO f = - try f - & catchApiException - - catchApiException :: IO (Either IOException a) -> App a - catchApiException action = - action - & fmap (first $ const ApiConnectionError) - & ExceptT + keepRetrying :: IO (Wreq.Response LByteString) -> App (Wreq.Response LByteString) + keepRetrying f = do + result <- (liftIO $ try f) :: App (Either IOException (Wreq.Response LByteString)) + case result of + Right x -> return x + _ -> keepRetrying f extractHeader :: Wreq.Response LByteString -> Text -> Text @@ -157,26 +176,60 @@ } +getFunctionResult :: UUID.UUID -> Text -> App (Maybe Text) +getFunctionResult u stdOut = do + let out = stdOut + & toText + & lines + + out + & takeWhile (/= uuid) + & traverse_ ( \t -> do + liftIO $ putTextLn t + liftIO $ hFlush stdout) + + out + & dropWhile (/= uuid) + & dropWhile (== uuid) + & nonEmpty + & fmap head + & return + where + uuid = toText $ UUID.toString u + + invoke :: Text -> Context -> App LambdaResult invoke event context = do handlerName <- readEnvironmentVariable "_HANDLER" runningDirectory <- readEnvironmentVariable "LAMBDA_TASK_ROOT" let contextJSON = decodeUtf8 $ encode context + uuid <- liftIO UUID.nextRandom out <- liftIO $ Process.readProcessWithExitCode (toString runningDirectory <> "/haskell_lambda") [ "--eventObject", toString event , "--contextObject", contextJSON , "--functionHandler", toString handlerName + , "--executionUuid", UUID.toString uuid ] "" case out of - (ExitSuccess, stdOut, _) -> pure (LambdaResult $ toText stdOut) - (_, stdOut, _) -> throwError (InvocationError $ toText stdOut) + (ExitSuccess, stdOut, _) -> do + res <- getFunctionResult uuid (toText stdOut) + case res of + Nothing -> throwError (ParseError "parsing result" $ toText stdOut) + Just value -> pure (LambdaResult value) + (_, stdOut, stdErr) -> + if stdErr /= "" + then throwError (InvocationError $ toText stdErr) + else do + res <- getFunctionResult uuid (toText stdOut) + case res of + Nothing -> throwError (ParseError "parsing error" $ toText stdOut) + Just value -> throwError (InvocationError value) publishResult :: Context -> Text -> LambdaResult -> App () -publishResult Context {..} lambdaApi (LambdaResult result) = do - let endpoint = "http://"<> lambdaApi <> "/2018-06-01/runtime/invocation/"<> awsRequestId <> "/response" - void $ liftIO $ Wreq.post (toString endpoint) (encodeUtf8 @Text @ByteString result) +publishResult Context {..} lambdaApi (LambdaResult result) = + void $ liftIO $ Wreq.post (responseEndpoint lambdaApi awsRequestId) (encodeUtf8 @Text @ByteString result) invokeAndPublish :: Context -> Text -> Text -> App () @@ -186,13 +239,14 @@ publishError :: Context -> Text -> RuntimeError -> App () -publishError Context {..} lambdaApiEndpoint (InvocationError err) = do - let endpoint = "http://"<> lambdaApiEndpoint <> "/2018-06-01/runtime/invocation/"<> awsRequestId <> "/error" - void (liftIO $ Wreq.post (toString endpoint) (encodeUtf8 @Text @ByteString err)) +publishError Context {..} lambdaApiEndpoint (InvocationError err) = + void (liftIO $ Wreq.post (invocationErrorEndpoint lambdaApiEndpoint awsRequestId) (encodeUtf8 @Text @ByteString err)) -publishError Context {..} lambdaApiEndpoint err = do - let endpoint = "http://"<> lambdaApiEndpoint <> "/2018-06-01/runtime/init/error" - void (liftIO $ Wreq.post (toString endpoint) (toJSON err)) +publishError Context {..} lambdaApiEndpoint (ParseError t t2) = + void (liftIO $ Wreq.post (invocationErrorEndpoint lambdaApiEndpoint awsRequestId) (toJSON $ ParseError t t2)) + +publishError Context {..} lambdaApiEndpoint err = + void (liftIO $ Wreq.post (runtimeInitErrorEndpoint lambdaApiEndpoint) (toJSON err)) lambdaRunner :: App () diff --git a/src/Aws/Lambda/ThHelpers.hs b/src/Aws/Lambda/ThHelpers.hs --- a/src/Aws/Lambda/ThHelpers.hs +++ b/src/Aws/Lambda/ThHelpers.hs @@ -1,4 +1,8 @@ -module Aws.Lambda.ThHelpers where +module Aws.Lambda.ThHelpers + ( pName + , eName + , recordQ + ) where import Relude import Language.Haskell.TH @@ -13,10 +17,6 @@ eName :: Text -> Q Exp eName = pure . VarE . mkName . toString --- | Helper for extracting fields of records --- think of @personAge@ in @myFunction Person { personAge = personAge } = ...@ -fName :: Text -> Q FieldPat -fName name = pure (mkName $ toString name, VarP $ mkName $ toString name) -- | Helper for extracting fields of a specified record -- it expects the constructor name as the first parameter, @@ -27,3 +27,8 @@ recordQ name fields = do extractedFields <- traverse fName fields pure $ RecP (mkName $ toString name) extractedFields + where + -- | Helper for extracting fields of records + -- think of @personAge@ in @myFunction Person { personAge = personAge } = ...@ + fName :: Text -> Q FieldPat + fName n = pure (mkName $ toString n, VarP $ mkName $ toString n) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,16 +1,8 @@ -import Relude hiding ( head ) - +import Relude import Test.Hspec -import Aws.Lambda.Runtime -import Aws.Lambda.Function - -handler :: Text -> c -> IO (Either String Int) -handler t _ = do - putTextLn t - return $ Right (42 :: Int) - main :: IO () -main = hspec $ describe "Impure lambda handler" $ do - it "runs" $ lambda handler +main = hspec $ describe "Useless test spec" $ do + it "runs" $ do + (1 + 1 :: Int) `shouldBe` (2 :: Int)