diff --git a/infernal.cabal b/infernal.cabal --- a/infernal.cabal +++ b/infernal.cabal @@ -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 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 diff --git a/src/Infernal.hs b/src/Infernal.hs --- a/src/Infernal.hs +++ b/src/Infernal.hs @@ -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)))) diff --git a/src/Infernal/Wai.hs b/src/Infernal/Wai.hs --- a/src/Infernal/Wai.hs +++ b/src/Infernal/Wai.hs @@ -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