infernal 0.6.0 → 0.7.0
raw patch · 3 files changed
+69/−60 lines, 3 filesdep ~aesondep ~http-clientdep ~little-logger
Dependency ranges changed: aeson, http-client, little-logger, little-rio
Files
- infernal.cabal +33/−22
- src/Infernal.hs +32/−34
- src/Infernal/Wai.hs +4/−4
infernal.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack ----- hash: 2f7de139b6f352da06ebe337ff14d48d201042872514dfcc65bc781b9071972e+-- hash: b8f529e1ade379020c2f1a1bf1088a3ccc107feae7178eb4be8506c82cca0452 name: infernal-version: 0.6.0+version: 0.7.0 synopsis: The Infernal Machine - An AWS Lambda Custom Runtime for Haskell description: Please see the README on GitHub at <https://github.com/ejconlon/infernal#readme> category: AWS@@ -33,26 +33,37 @@ Paths_infernal hs-source-dirs: src- default-extensions: ConstraintKinds DeriveFunctor DeriveFoldable DeriveGeneric DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings Rank2Types TemplateHaskell+ 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.5 && <1.6+ aeson ==2.0.* , base >=4.12 && <5- , 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+ , binary ==0.8.*+ , bytestring ==0.10.*+ , case-insensitive ==1.2.*+ , exceptions ==0.10.*+ , hashable ==1.3.*+ , http-client ==0.7.*+ , http-types ==0.12.*+ , little-logger >=1.0.1 && <1.1+ , little-rio >=1.0.1 && <1.1+ , microlens ==0.4.*+ , microlens-mtl ==0.2.*+ , microlens-th ==0.4.*+ , mtl ==2.2.*+ , text ==1.2.*+ , unliftio-core ==0.2.*+ , unordered-containers ==0.2.*+ , wai ==3.2.* default-language: Haskell2010
src/Infernal.hs view
@@ -23,7 +23,7 @@ , runSimpleLambda ) where -import Control.Exception (Exception, SomeException, fromException)+import Control.Exception (Exception (displayException), SomeException, fromException) import Control.Monad (forever, void) import Control.Monad.Catch (MonadCatch (..), MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..))@@ -37,13 +37,13 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) import Lens.Micro (Lens') import Lens.Micro.Mtl (view) import Lens.Micro.TH (makeLenses)-import LittleLogger (HasSimpleLog (..), SimpleLogAction, WithSimpleLog, defaultSimpleLogAction, logDebug, logError,- logException)+import LittleLogger (HasLogAction (..), LogAction, MonadLogger, WithLogAction, defaultLogAction, logDebugN, logErrorN) import LittleRIO (RIO, runRIO, unliftRIO) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Types as HT@@ -59,6 +59,9 @@ instance ToText Text where toText = id +exnText :: Exception e => e -> Text+exnText = T.pack . displayException+ -- | The UUID associated with a Lambda request. newtype LambdaRequestId = LambdaRequestId { _unLambdaRequestId :: Text@@ -111,13 +114,13 @@ data LambdaEnv = LambdaEnv { _leManager :: !HC.Manager , _leVars :: !LambdaVars- , _leSimpleLog :: !SimpleLogAction+ , _leLogAction :: !LogAction } $(makeLenses ''LambdaEnv) -instance HasSimpleLog LambdaEnv where- simpleLogL = leSimpleLog+instance HasLogAction LambdaEnv where+ logActionL = leLogAction class HasLambdaEnv env where lambdaEnvL :: Lens' env LambdaEnv@@ -188,50 +191,47 @@ catchRethrowExitCode :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchRethrowExitCode = catchRethrowWhen (isJust . castExitCode) -handleInvokeError :: WithSimpleLog env m => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> SomeException -> m ()+handleInvokeError :: (MonadLogger m, MonadIO m) => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> SomeException -> m () handleInvokeError postErr unio invokeErrCb lamReq err = do let lamReqId = _lreqId lamReq- logError ("Caught invocation error for request id " <> toText lamReqId <> ":")- logException err+ logErrorN ("Caught invocation error for request id " <> toText lamReqId <> ": " <> exnText err) lamErr <- case castLambdaError err of Just lamErr -> do- logError ("Posting original invocation error for request id " <> toText lamReqId)+ logErrorN ("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 " <> toText lamReqId <> ":")- logException lamErr+ logErrorN ("Posting new invocation error for request id " <> toText lamReqId <> ": " <> exnText lamErr) pure lamErr postErr lamReqId lamErr -guardInvokeError :: (MonadCatch m, WithSimpleLog env m) => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> m () -> m ()+guardInvokeError :: (MonadCatch m, MonadLogger m, MonadIO m) => PostLambdaInvokeError m -> UnliftIO n -> InvokeErrorCallback n -> LambdaRequest -> m () -> m () guardInvokeError postErr unio invokeErrCb lamReq body = catchRethrowExitCode body (handleInvokeError postErr unio invokeErrCb lamReq) missedDeadlineError :: Int -> LambdaError missedDeadlineError deadlineMs = LambdaError "MissedDeadlineError" ("Missed adjusted deadline of " <> Text.pack (show deadlineMs) <> "ms.") -pollAndRespond :: (MonadCatch m, WithSimpleLog env m) => LambdaClient m -> UnliftIO n -> CallbackConfig n -> m ()+pollAndRespond :: (MonadCatch m, MonadLogger m, MonadIO m) => LambdaClient m -> UnliftIO n -> CallbackConfig n -> m () pollAndRespond client unio cbc = do let runCb = _cbcRunCallback cbc invokeErrCb = _cbcInvokeErrorCallback cbc postErr = _lcPostLambdaInvokeError client postRep = _lcPostLambdaResponse client- logDebug "Polling for request"+ logDebugN "Polling for request" lamReq <- _lcGetLambdaRequest client let lamReqId = _lreqId lamReq- logDebug ("Servicing request id " <> toText lamReqId)+ logDebugN ("Servicing request id " <> toText lamReqId) guardInvokeError postErr unio invokeErrCb lamReq $ do lamRepBody <- unliftInto unio (runCb lamReq)- logDebug ("Posting response to request id " <> toText lamReqId)+ logDebugN ("Posting response to request id " <> toText lamReqId) postRep lamReqId lamRepBody- logDebug ("Finished request id " <> toText lamReqId)+ logDebugN ("Finished request id " <> toText lamReqId) -pollLoop :: (MonadCatch m, WithSimpleLog env m) => LambdaClient m -> UnliftIO n -> CallbackConfig n -> m ()+pollLoop :: (MonadCatch m, MonadLogger m, MonadIO m) => LambdaClient m -> UnliftIO n -> CallbackConfig n -> m () pollLoop client unio cbc = let uncaughtErrCb = _cbcUncaughtErrorCallback cbc in forever $ catchRethrowExitCode (pollAndRespond client unio cbc) $ \err -> do- logError "Handling uncaught error:"- logException err+ logErrorN ("Handling uncaught error: " <> exnText err) unliftInto unio (uncaughtErrCb err) getEnvText :: MonadIO m => Text -> m Text@@ -258,12 +258,12 @@ , _lvHandlerName = handlerName } -newLambdaEnv :: (MonadThrow m, WithSimpleLog env m) => m LambdaEnv+newLambdaEnv :: (MonadThrow m, WithLogAction env m) => m LambdaEnv newLambdaEnv = do manager <- liftIO (HC.newManager httpManagerSettings) vars <- readLambdaVars- simpleLog <- view simpleLogL- pure (LambdaEnv manager vars simpleLog)+ logAction <- view logActionL+ pure (LambdaEnv manager vars logAction) type MonadLambdaImpl env m = (MonadIO m, MonadThrow m, MonadReader env m, HasLambdaEnv env) @@ -374,35 +374,33 @@ -- This runs the main loop of our AWS Lambda Custom Runtime to fetch invocations, process them, and report errors or results. -- Control will not return from this function, and AWS Lambda will terminate the process at its will. runLambda ::- (MonadCatch m, WithSimpleLog env m)+ (MonadCatch m, WithLogAction env m, MonadLogger m) => UnliftIO n -- ^ Runs your monad @n@ in IO (see @MonadUnliftIO@ from @unliftio-core@) -> InitErrorCallback n -- ^ Error mapper for the callback builder -> (LambdaVars -> n (CallbackConfig n)) -- ^ Callback builder. When possible, do init work here so the framework can propagate init errors to AWS. -> m () runLambda unio initErrCb cbcInit = do- logDebug "Initializing lambda environment"+ logDebugN "Initializing lambda environment" lambdaEnv <- newLambdaEnv runRIO lambdaEnv $ do let client = lambdaClientImpl lamVars = _leVars lambdaEnv- logDebug "Initializing callbacks"+ logDebugN "Initializing callbacks" cbc <- catchRethrow (unliftInto unio (cbcInit lamVars)) $ \err -> do- logError "Caught initialization error:"- logException err+ logErrorN ("Caught initialization error: " <> exnText err) lamErr <- unliftInto unio (initErrCb err)- logError "Posting mapped initialization error:"- logException lamErr+ logErrorN ("Posting mapped initialization error: " <> exnText lamErr) _lcPostLambdaInitError client lamErr- logDebug "Starting poll loop"+ logDebugN "Starting poll loop" pollLoop client unio cbc -- | 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 SimpleLogAction) -> IO ()+runSimpleLambda :: RunCallback (RIO LogAction) -> IO () runSimpleLambda cb = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering- let app = defaultSimpleLogAction+ let app = defaultLogAction unio <- unliftRIO app runRIO app (runLambda unio defaultInitErrorCallback (const (pure (defaultCallbackConfig cb))))
src/Infernal/Wai.hs view
@@ -21,7 +21,7 @@ import Data.Text.Encoding (decodeUtf8) import Infernal (RunCallback, decodeRequest, encodeResponse, runSimpleLambda) import Infernal.Events.APIGateway (APIGatewayProxyRequest (..), APIGatewayProxyResponse (..))-import LittleLogger (WithSimpleLog, logDebug)+import LittleLogger (MonadLogger, WithLogAction, logDebugN) import Network.Wai (Application, Response, StreamingBody, defaultRequest, responseToStream) import Network.Wai.Internal (Request (..), ResponseReceived (..)) import Prelude@@ -68,12 +68,12 @@ liftIO (takeMVar v) -- | Adapt a WAI 'Application' into a 'RunCallback' to handle API Gateway proxy requests encoded as Lambda requests.-applicationCallback :: (MonadThrow n, WithSimpleLog env n) => Application -> RunCallback n+applicationCallback :: (MonadThrow n, WithLogAction env n, MonadLogger n) => Application -> RunCallback n applicationCallback app lamReq = do proxyReq <- decodeRequest lamReq- logDebug ("Servicing proxy request " <> decodeUtf8 (_agprqHttpMethod proxyReq) <> " " <> decodeUtf8 (_agprqPath proxyReq))+ logDebugN ("Servicing proxy request " <> decodeUtf8 (_agprqHttpMethod proxyReq) <> " " <> decodeUtf8 (_agprqPath proxyReq)) proxyRep <- adaptApplication app proxyReq- logDebug ("Responding with status " <> Text.pack (show (_agprsStatusCode proxyRep)))+ logDebugN ("Responding with status " <> Text.pack (show (_agprsStatusCode proxyRep))) let lamRep = encodeResponse proxyRep pure lamRep