packages feed

aws-lambda-haskell-runtime (empty) → 1.0.3

raw patch · 10 files changed

+573/−0 lines, 10 filesdep +QuickCheckdep +aesondep +aws-lambda-haskell-runtimesetup-changed

Dependencies added: QuickCheck, aeson, aws-lambda-haskell-runtime, base, bytestring, case-insensitive, conduit, directory, filepath, hspec, loch-th, microlens-platform, mtl, optparse-generic, process, relude, template-haskell, text, time, wreq

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for aws-lambda-haskell-runtime++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+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.++    * 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 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.++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,3 @@+# Haskell Runtime for AWS Lambda++This package provides a way of running Haskell projects on AWS Lambda.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import Relude+import Aws.Lambda.Runtime+++main :: IO ()+main = forever $ do+  res <- runExceptT lambdaRunner+  case res of+    Right _ -> return ()+    Left err  -> putTextLn $ show err
+ aws-lambda-haskell-runtime.cabal view
@@ -0,0 +1,120 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 02a8925f43833b749c1ca3142186ae27cfc292a99c4ebb031209592bed2753df++name:           aws-lambda-haskell-runtime+version:        1.0.3+synopsis:       Haskell runtime for AWS Lambda+description:    Please see the README on GitHub at <https://github.com/githubuser/aws-lambda-haskell-runtime#readme>+category:       AWS+homepage:       https://github.com/theam/aws-lambda-haskell-runtime#readme+bug-reports:    https://github.com/theam/aws-lambda-haskell-runtime/issues+author:         Nikita Tchayka+maintainer:     hackers@theagilemonkeys.com+copyright:      2018 The Agile Monkeys SL+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/theam/aws-lambda-haskell-runtime++library+  exposed-modules:+      Aws.Lambda.Runtime+      Aws.Lambda.Configuration+  other-modules:+      Aws.Lambda.ThHelpers+      Paths_aws_lambda_haskell_runtime+  hs-source-dirs:+      src+  default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables NoImplicitPrelude DeriveGeneric TypeApplications+  ghc-options: -Wall -optP-Wno-nonportable-include-path+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , directory+    , filepath+    , loch-th+    , microlens-platform+    , mtl+    , optparse-generic+    , process+    , relude+    , template-haskell+    , text+    , time+    , wreq+  default-language: Haskell2010++executable bootstrap+  main-is: Main.hs+  other-modules:+      Paths_aws_lambda_haskell_runtime+  hs-source-dirs:+      app+  default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables NoImplicitPrelude DeriveGeneric TypeApplications+  ghc-options: -Wall -optP-Wno-nonportable-include-path+  build-depends:+      aeson+    , aws-lambda-haskell-runtime+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , directory+    , filepath+    , loch-th+    , microlens-platform+    , mtl+    , optparse-generic+    , process+    , relude+    , template-haskell+    , text+    , time+    , wreq+  default-language: Haskell2010++test-suite aws-lambda-haskell-runtime-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_aws_lambda_haskell_runtime+  hs-source-dirs:+      test+  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+    , hspec+    , loch-th+    , microlens-platform+    , mtl+    , optparse-generic+    , process+    , relude+    , template-haskell+    , text+    , time+    , wreq+  default-language: Haskell2010
+ src/Aws/Lambda/Configuration.hs view
@@ -0,0 +1,154 @@+module Aws.Lambda.Configuration+  ( LambdaOptions (..)+  , configureLambda+  , returnAndFail+  , returnAndSucceed+  , decodeObj+  , Options.getRecord+  )+where++import Data.Aeson+import Relude++import qualified Data.Text as Text+import Language.Haskell.TH+import qualified Options.Generic as Options+import qualified Conduit as Conduit+import qualified System.Directory as Directory+import System.FilePath ((</>))+import System.IO.Error++import Aws.Lambda.ThHelpers+++data LambdaOptions = LambdaOptions+  { eventObject     :: Text+  , contextObject   :: Text+  , functionHandler :: Text+  } deriving (Generic)+instance Options.ParseRecord LambdaOptions+++mkMain :: Q [Dec]+mkMain = [d|+  $(pName "main") = getRecord "" >>= run+  |]++mkRun :: Q Dec+mkRun = do+  handlers <- runIO getHandlers+  clause' <- recordQ "LambdaOptions" ["functionHandler", "contextObject", "eventObject"]+  body <- dispatcherCaseQ handlers+  pure $ FunD (mkName "run") [Clause [clause'] (NormalB body) []]+++dispatcherCaseQ :: [Text] -> Q Exp+dispatcherCaseQ fileNames = do+  caseExp <- eName "functionHandler"+  matches <- traverse handlerCaseQ fileNames+  unmatched <- unmatchedCaseQ+  pure $ CaseE caseExp (matches <> [unmatched])+++handlerCaseQ :: Text -> Q Match+handlerCaseQ lambdaHandler = do+  let pattern = LitP (StringL $ toString lambdaHandler)+  body <- [e|do+    result <- $(eName qualifiedName) (decodeObj $(eName "eventObject")) (decodeObj $(eName "contextObject"))+    either returnAndFail returnAndSucceed result+    |]+  pure $ Match pattern (NormalB body) []+ where+  qualifiedName =+    lambdaHandler+    & Text.dropWhile (/= '/')+    & Text.drop 1+    & Text.replace "/" "."+++unmatchedCaseQ :: Q Match+unmatchedCaseQ = do+  let pattern = WildP+  body <- [e|+    returnAndFail ("Handler " <> $(eName "functionHandler") <> " does not exist on project")+    |]+  pure $ Match pattern (NormalB body) []++configureLambda :: Q [Dec]+configureLambda = do+  main <- mkMain+  run <- mkRun+  return $ main <> [run]+++returnAndFail :: ToJSON a => a -> IO ()+returnAndFail v = do+ putTextLn (decodeUtf8 $ encode v)+ exitFailure++returnAndSucceed :: ToJSON a => a -> IO ()+returnAndSucceed v = do+ putTextLn (decodeUtf8 $ encode v)+ exitSuccess++decodeObj :: FromJSON a => Text -> a+decodeObj x = (decode $ encodeUtf8 x) ?: error $ "Could not decode event " <> x++data DirContent = DirList [FilePath] [FilePath]+                | DirError IOError+data DirData = DirData FilePath DirContent++-- Produces directory data+walk :: FilePath -> Conduit.Source IO DirData+walk path = do+  result <- lift $ tryIOError listdir+  case result of+    Right dl@(DirList subdirs files) -> do+      Conduit.yield (DirData path dl)+      forM_ subdirs (walk . (path </>))+    Right e -> Conduit.yield (DirData path e)+    Left e -> Conduit.yield (DirData path (DirError e))+ where+  listdir = do+    entries <- Directory.getDirectoryContents path >>= filterHidden+    subdirs <- filterM isDir entries+    files   <- filterM isFile entries+    return $ DirList subdirs files+   where+    isFile entry = Directory.doesFileExist (path </> entry)+    isDir entry = Directory.doesDirectoryExist (path </> entry)+    filterHidden paths = return $ filter (\p -> head (fromMaybe (error "") $ nonEmpty p) /= '.') paths+++-- Consume directories+myVisitor :: Conduit.Sink DirData IO [FilePath]+myVisitor = loop []+ where+  loop n = do+    r <- Conduit.await+    case r of+      Nothing -> return n+      Just r  -> loop (process r <> n)+  process (DirData _ (DirError _)) = []+  process (DirData dir (DirList _ files)) = map (\f -> dir <> "/" <> f) files+++getHandlers :: IO [Text]+getHandlers = do+  files <- Conduit.runConduit $ walk "." Conduit..| myVisitor+  handlerFiles <- files+                   & fmap toText+                   & filter (Text.isSuffixOf ".hs")+                   & filterM containsHandler+                   & fmap (fmap $ Text.dropEnd 3)+                   & fmap (fmap $ Text.drop 2)+                   & fmap (fmap (<> ".handler"))+  return handlerFiles+++containsHandler :: Text -> IO Bool+containsHandler file = do+  fileContents <- readFile $ toString file+  return $ "handler :: " `Text.isInfixOf` fileContents+        && "IO (Either " `Text.isInfixOf` fileContents
+ src/Aws/Lambda/Runtime.hs view
@@ -0,0 +1,204 @@+module Aws.Lambda.Runtime where++import Control.Exception (IOException, try)+import Control.Monad.Except (catchError, throwError)+import Data.Aeson+import Relude hiding (get, identity)+import System.Exit (ExitCode (..))++import qualified Data.CaseInsensitive as CI+import Lens.Micro.Platform hiding ((.=))+import qualified Network.Wreq as Wreq+import qualified System.Environment as Environment+import qualified System.Process as Process+++type App a =+  ExceptT RuntimeError IO a+++data RuntimeError+  = EnvironmentVariableNotSet Text+  | ApiConnectionError+  | ApiHeaderNotSet Text+  | ParseError Text Text+  | InvocationError Text+  deriving (Show)+instance Exception RuntimeError++instance ToJSON RuntimeError where+  toJSON (EnvironmentVariableNotSet msg) = object+    [ "errorType" .= ("EnvironmentVariableNotSet" :: Text)+    , "errorMessage" .= msg+    ]++  toJSON ApiConnectionError = object+    [ "errorType" .= ("ApiConnectionError" :: Text)+    , "errorMessage" .= ("Could not connect to API to retrieve AWS Lambda parameters" :: Text)+    ]++  toJSON (ApiHeaderNotSet headerName) = object+    [ "errorType" .= ("ApiHeaderNotSet" :: Text)+    , "errorMessage" .= headerName+    ]++  toJSON (ParseError objectBeingParsed value) = object+    [ "errorType" .= ("ParseError" :: Text)+    , "errorMessage" .= ("Parse error for " <> objectBeingParsed <> ", could not parse value '" <> value <> "'")+    ]++  -- We return the user error as it is+  toJSON (InvocationError err) = toJSON err++++data Context = Context+  { memoryLimitInMb    :: !Int+  , functionName       :: !Text+  , functionVersion    :: !Text+  , invokedFunctionArn :: !Text+  , awsRequestId       :: !Text+  , xrayTraceId        :: !Text+  , logStreamName      :: !Text+  , logGroupName       :: !Text+  , deadline           :: !Int+  } deriving (Generic)+instance FromJSON Context+instance ToJSON Context+++newtype LambdaResult =+  LambdaResult Text+++readEnvironmentVariable :: Text -> App Text+readEnvironmentVariable envVar = do+  v <- lift (Environment.lookupEnv $ toString envVar)+  case v of+    Nothing    -> throwError (EnvironmentVariableNotSet envVar)+    Just value -> pure (toText value)+++readFunctionMemory :: App Int+readFunctionMemory = do+  let envVar = "AWS_LAMBDA_FUNCTION_MEMORY_SIZE"+  let parseMemory txt = readMaybe (toString txt)+  memoryValue <- readEnvironmentVariable envVar+  case parseMemory memoryValue of+    Just value -> pure value+    Nothing    -> throwError (ParseError envVar memoryValue)+++getApiData :: Text -> App (Wreq.Response LByteString)+getApiData endpoint =+  tryIO (Wreq.get nextInvocationEndpoint)+ 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+++extractHeader :: Wreq.Response LByteString -> Text -> Text+extractHeader apiData header =+  decodeUtf8 (apiData ^. Wreq.responseHeader (CI.mk $ encodeUtf8 header))+++extractIntHeader :: Wreq.Response LByteString -> Text -> App Int+extractIntHeader apiData headerName = do+  let header = extractHeader apiData headerName+  case readMaybe $ toString header of+    Nothing    -> throwError (ParseError "deadline" header)+    Just value -> pure value+++extractBody :: Wreq.Response LByteString -> Text+extractBody apiData =+  decodeUtf8 (apiData ^. Wreq.responseBody)+++propagateXRayTrace :: Text -> App ()+propagateXRayTrace xrayTraceId =+  liftIO $ Environment.setEnv "_X_AMZN_TRACE_ID" $ toString xrayTraceId+++initializeContext :: Wreq.Response LByteString -> App Context+initializeContext apiData = do+  functionName          <- readEnvironmentVariable "AWS_LAMBDA_FUNCTION_NAME"+  version               <- readEnvironmentVariable "AWS_LAMBDA_FUNCTION_VERSION"+  logStream             <- readEnvironmentVariable "AWS_LAMBDA_LOG_STREAM_NAME"+  logGroup              <- readEnvironmentVariable "AWS_LAMBDA_LOG_GROUP_NAME"+  memoryLimitInMb       <- readFunctionMemory+  deadline              <- extractIntHeader apiData "Lambda-Runtime-Deadline-Ms"+  let xrayTraceId        = extractHeader apiData "Lambda-Runtime-Trace-Id"+  let awsRequestId       = extractHeader apiData "Lambda-Runtime-Aws-Request-Id"+  let invokedFunctionArn = extractHeader apiData "Lambda-Runtime-Invoked-Function-Arn"+  propagateXRayTrace xrayTraceId+  pure $ Context+    { functionName       = functionName+    , functionVersion    = version+    , logStreamName      = logStream+    , logGroupName       = logGroup+    , memoryLimitInMb    = memoryLimitInMb+    , invokedFunctionArn = invokedFunctionArn+    , xrayTraceId        = xrayTraceId+    , awsRequestId       = awsRequestId+    , deadline           = deadline+    }+++invoke :: Text -> Context -> App LambdaResult+invoke event context = do+  handlerName <- readEnvironmentVariable "_HANDLER"+  runningDirectory <- readEnvironmentVariable "LAMBDA_TASK_ROOT"+  let contextJSON = decodeUtf8 $ encode context+  out <- liftIO $ Process.readProcessWithExitCode (toString runningDirectory <> "/haskell_lambda")+                [ "--eventObject", toString event+                , "--contextObject", contextJSON+                , "--functionHandler", toString handlerName+                ]+                ""+  case out of+    (ExitSuccess, stdOut, _) -> pure (LambdaResult $ toText stdOut)+    (_, stdOut, _)           -> throwError (InvocationError $ toText stdOut)+++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)+++invokeAndPublish :: Context -> Text -> Text -> App ()+invokeAndPublish ctx event lambdaApiEndpoint = do+  res <- invoke event ctx+  publishResult ctx lambdaApiEndpoint res+++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 err = do+  let endpoint = "http://"<> lambdaApiEndpoint <> "/2018-06-01/runtime/init/error"+  void (liftIO $ Wreq.post (toString endpoint) (toJSON err))+++lambdaRunner :: App ()+lambdaRunner = do+  lambdaApiEndpoint     <- readEnvironmentVariable "AWS_LAMBDA_RUNTIME_API"+  apiData               <- getApiData lambdaApiEndpoint+  let event = extractBody apiData+  ctx <- initializeContext apiData+  invokeAndPublish ctx event lambdaApiEndpoint `catchError` publishError ctx lambdaApiEndpoint
+ src/Aws/Lambda/ThHelpers.hs view
@@ -0,0 +1,29 @@+module Aws.Lambda.ThHelpers where++import Relude+import Language.Haskell.TH++-- | Helper for defining names in declarations+-- think of @myValue@ in @myValue = 2@+pName :: Text -> Q Pat+pName = pure . VarP . mkName . toString++-- | Helper for defining names in expressions+-- think of @myFunction@ in @quux = myFunction 3@+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,+-- and the list of fields to bring into scope as second+-- think of @Person@, and @personAge@, @personName@ in+-- @myFunction Person { personAge, personName } = ...@+recordQ :: Text -> [Text] -> Q Pat+recordQ name fields = do+  extractedFields <- traverse fName fields+  pure $ RecP (mkName $ toString name) extractedFields
+ test/Spec.hs view
@@ -0,0 +1,16 @@+import           Relude                  hiding ( head )++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