diff --git a/infernal.cabal b/infernal.cabal --- a/infernal.cabal +++ b/infernal.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 3e72ee8a176a23ff4e8b2e60f739ffe4798421d4f70cbd236dc7c34e7e953d2d +-- hash: 2f7de139b6f352da06ebe337ff14d48d201042872514dfcc65bc781b9071972e name: infernal -version: 0.5.0 +version: 0.6.0 synopsis: The Infernal Machine - An AWS Lambda Custom Runtime for Haskell description: Please see the README on GitHub at category: AWS @@ -36,23 +36,23 @@ default-extensions: ConstraintKinds DeriveFunctor DeriveFoldable DeriveGeneric DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings Rank2Types TemplateHaskell ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -fno-warn-warnings-deprecations build-depends: - aeson >=1.4 + aeson >=1.5 && <1.6 , base >=4.12 && <5 - , binary >=0.8 - , bytestring >=0.10 - , case-insensitive >=1.2 - , exceptions >=0.10 - , hashable >=1.3 - , http-client >=0.6 - , http-types >=0.12 - , little-logger >=0.1 - , little-rio >=0.1 - , microlens >=0.4 - , microlens-mtl >=0.2 - , microlens-th >=0.4 - , mtl >=2.2 - , text >=1.2 - , unliftio-core >=0.1 - , unordered-containers >=0.2 - , wai >=3.2 + , binary >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 + , case-insensitive >=1.2 && <1.3 + , exceptions >=0.10 && <0.11 + , hashable >=1.3 && <1.4 + , http-client >=0.6 && <0.7 + , http-types >=0.12 && <0.13 + , little-logger >=0.3 && <0.4 + , little-rio >=0.2 && <0.3 + , microlens >=0.4 && <0.5 + , microlens-mtl >=0.2 && <0.3 + , microlens-th >=0.4 && <0.5 + , mtl >=2.2 && <2.3 + , text >=1.2 && <1.3 + , unliftio-core >=0.2 && <0.3 + , unordered-containers >=0.2 && <0.3 + , wai >=3.2 && <3.3 default-language: Haskell2010 diff --git a/src/Infernal.hs b/src/Infernal.hs --- a/src/Infernal.hs +++ b/src/Infernal.hs @@ -42,8 +42,8 @@ import Lens.Micro (Lens') import Lens.Micro.Mtl (view) import Lens.Micro.TH (makeLenses) -import LittleLogger (HasSimpleLog (..), LogApp, SimpleLogAction, WithSimpleLog, logDebug, logError, logException, - newLogApp) +import LittleLogger (HasSimpleLog (..), SimpleLogAction, WithSimpleLog, defaultSimpleLogAction, logDebug, logError, + logException) import LittleRIO (RIO, runRIO, unliftRIO) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Types as HT @@ -53,24 +53,30 @@ import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) +class ToText a where + toText :: a -> Text + +instance ToText Text where + toText = id + -- | The UUID associated with a Lambda request. newtype LambdaRequestId = LambdaRequestId { _unLambdaRequestId :: Text - } deriving newtype (Eq, Show, Ord, IsString, Hashable) + } deriving newtype (Eq, Show, Ord, IsString, Hashable, ToText) -- | The request parsed from the "next invocation" API () data LambdaRequest = LambdaRequest - { _lreqId :: !LambdaRequestId -- ^ From the @Lambda-Runtime-Aws-Request-Id@ header - , _lreqTraceId :: !Text -- ^ From the @Lambda-Runtime-Trace-Id@ header - , _lreqFunctionArn :: !Text -- ^ From the @Lambda-Runtime-Invoked-Function-Arn@ header - , _lreqDeadlineMs :: !Int -- ^ From the @Lambda-Runtime-Deadline-Ms@ header, an epoch deadline in ms - , _lreqBody :: !LBS.ByteString -- ^ The unparsed request body. Typically you will 'Data.Aeson.decode' this. + { _lreqId :: !LambdaRequestId -- ^ From the @Lambda-Runtime-Aws-Request-Id@ header + , _lreqTraceId :: !(Maybe Text) -- ^ From the @Lambda-Runtime-Trace-Id@ header + , _lreqFunctionArn :: !(Maybe Text) -- ^ From the @Lambda-Runtime-Invoked-Function-Arn@ header + , _lreqDeadlineMs :: !Int -- ^ From the @Lambda-Runtime-Deadline-Ms@ header, an epoch deadline in ms + , _lreqBody :: !LBS.ByteString -- ^ The unparsed request body. Typically you will 'Data.Aeson.decode' this. } deriving stock (Eq, Show) -- | A response to the 'LambdaRequest', typically as encoded JSON. newtype LambdaResponse = LambdaResponse { _unLambdaResponse :: LBS.ByteString - } deriving (Eq, Show, Ord, IsString, Hashable) + } deriving newtype (Eq, Show, Ord, IsString, Hashable) -- | An error formatted to propagate to AWS (). -- Note that this is an 'Exception' so you can throw it to short-circuit processing and report useful information. By default, if you throw @@ -184,19 +190,19 @@ handleInvokeError :: WithSimpleLog env m => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> SomeException -> m () handleInvokeError postErr unio invokeErrCb lamReq err = do - let lamIdText = _unLambdaRequestId (_lreqId lamReq) - logError ("Caught invocation error for request id " <> lamIdText <> ":") + let lamReqId = _lreqId lamReq + logError ("Caught invocation error for request id " <> toText lamReqId <> ":") logException err lamErr <- case castLambdaError err of Just lamErr -> do - logError ("Posting original invocation error for request id " <> lamIdText) + logError ("Posting original invocation error for request id " <> toText lamReqId) pure lamErr Nothing -> do lamErr <- unliftInto unio (invokeErrCb lamReq err) - logError ("Posting new invocation error for request id " <> lamIdText <> ":") + logError ("Posting new invocation error for request id " <> toText lamReqId <> ":") logException lamErr pure lamErr - postErr (_lreqId lamReq) lamErr + postErr lamReqId lamErr guardInvokeError :: (MonadCatch m, WithSimpleLog env m) => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> m () -> m () guardInvokeError postErr unio invokeErrCb lamReq body = catchRethrowExitCode body (handleInvokeError postErr unio invokeErrCb lamReq) @@ -213,13 +219,12 @@ logDebug "Polling for request" lamReq <- _lcGetLambdaRequest client let lamReqId = _lreqId lamReq - lamIdText = _unLambdaRequestId lamReqId - logDebug ("Servicing request id " <> lamIdText) + logDebug ("Servicing request id " <> toText lamReqId) guardInvokeError postErr unio invokeErrCb lamReq $ do lamRepBody <- unliftInto unio (runCb lamReq) - logDebug ("Posting response to request id " <> lamIdText) + logDebug ("Posting response to request id " <> toText lamReqId) postRep lamReqId lamRepBody - logDebug ("Finished request id " <> lamIdText) + logDebug ("Finished request id " <> toText lamReqId) pollLoop :: (MonadCatch m, WithSimpleLog env m) => LambdaClient m -> UnliftIO n -> CallbackConfig n -> m () pollLoop client unio cbc = @@ -294,17 +299,17 @@ invalidDeadlineError :: Text -> LambdaError invalidDeadlineError deadlineMsText = LambdaError "InvalidDeadlineError" ("Invalid value for deadline: " <> deadlineMsText) +lookupOptionalHeader :: Text -> HT.ResponseHeaders -> Maybe Text +lookupOptionalHeader name = fmap decodeUtf8 . lookup (CI.mk (encodeUtf8 name)) + lookupHeader :: MonadThrow m => Text -> HT.ResponseHeaders -> m Text -lookupHeader name headers = - case lookup (CI.mk (encodeUtf8 name)) headers of - Nothing -> throwM (missingHeaderError name) - Just value -> pure (decodeUtf8 value) +lookupHeader name = maybe (throwM (missingHeaderError name)) pure . lookupOptionalHeader name parseLambdaRequest :: MonadThrow m => HT.ResponseHeaders -> LBS.ByteString -> m LambdaRequest parseLambdaRequest headers body = do reqId <- lookupHeader "Lambda-Runtime-Aws-Request-Id" headers - traceId <- lookupHeader "Lambda-Runtime-Trace-Id" headers - functionArn <- lookupHeader "Lambda-Runtime-Invoked-Function-Arn" headers + let traceId = lookupOptionalHeader "Lambda-Runtime-Trace-Id" headers + functionArn = lookupOptionalHeader "Lambda-Runtime-Invoked-Function-Arn" headers deadlineMsText <- lookupHeader "Lambda-Runtime-Deadline-Ms" headers deadlineMs <- case readMaybe (Text.unpack deadlineMsText) of Just value -> pure value @@ -338,10 +343,10 @@ postLambdaInitErrorImpl = postRequest ["init", "error"] . encode postLambdaInvokeErrorImpl :: MonadLambdaImpl env m => PostLambdaInvokeError m -postLambdaInvokeErrorImpl lamReqId = postRequest ["invocation", _unLambdaRequestId lamReqId, "error"] . encode +postLambdaInvokeErrorImpl lamReqId = postRequest ["invocation", toText lamReqId, "error"] . encode postLambdaResponseImpl :: MonadLambdaImpl env m => PostLambdaResponse m -postLambdaResponseImpl lamReqId = postRequest ["invocation", _unLambdaRequestId lamReqId, "response"] . _unLambdaResponse +postLambdaResponseImpl lamReqId = postRequest ["invocation", toText lamReqId, "response"] . _unLambdaResponse lambdaClientImpl :: MonadLambdaImpl env m => LambdaClient m lambdaClientImpl = LambdaClient @@ -394,10 +399,10 @@ -- | A simple entrypoint that delegates to 'runLambda'. Use this as the body of your @main@ function if you want to get a Lambda function up and running quickly. -- All you need to do is provide a 'RunCallback' that handles JSON-encoded requests and returns JSON-encoded responses (or throws 'LambdaError' exceptions). -- Your callback has access to a simple logger (try 'logDebug', for example) whose output will be collected by Lambda and published to CloudWatch. -runSimpleLambda :: RunCallback (RIO LogApp) -> IO () +runSimpleLambda :: RunCallback (RIO SimpleLogAction) -> IO () runSimpleLambda cb = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - let app = newLogApp + let app = defaultSimpleLogAction unio <- unliftRIO app runRIO app (runLambda unio defaultInitErrorCallback (const (pure (defaultCallbackConfig cb))))