infernal 0.3.0 → 0.4.0
raw patch · 7 files changed
+148/−18 lines, 7 filesdep +co-logdep +co-log-coredep +hashabledep −heart-appdep −heart-core
Dependencies added: co-log, co-log-core, hashable, microlens, microlens-mtl, microlens-th, unliftio-core
Dependencies removed: heart-app, heart-core
Files
- infernal.cabal +14/−6
- src/Infernal.hs +19/−7
- src/Infernal/Events/APIGateway.hs +5/−2
- src/Infernal/Internal/App.hs +20/−0
- src/Infernal/Internal/Logging.hs +61/−0
- src/Infernal/Internal/RIO.hs +24/−0
- src/Infernal/Wai.hs +5/−3
infernal.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: a5e5af8e888606c56383340240a1e597cd6d9b3925850095b0ccd08074d9b07c+-- hash: fe4ff780bb0fb36d6c0cbda85811c8885ccf1ac40f4fae4f0cb83a7be7cfc641 name: infernal-version: 0.3.0+version: 0.4.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@@ -28,12 +28,15 @@ exposed-modules: Infernal Infernal.Events.APIGateway+ Infernal.Internal.App+ Infernal.Internal.Logging+ Infernal.Internal.RIO Infernal.Wai other-modules: Paths_infernal hs-source-dirs: src- default-extensions: ConstraintKinds DeriveFunctor DeriveFoldable DeriveGeneric DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings 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.4@@ -41,15 +44,20 @@ , binary >=0.8 , bytestring >=0.10 , case-insensitive >=1.2+ , co-log >=0.4+ , co-log-core >=0.2 , containers >=0.6 , exceptions >=0.10- , heart-app >=0.1.1- , heart-core >=0.1.1+ , hashable >=1.3 , http-client >=0.6 , http-types >=0.12+ , microlens >=0.4+ , microlens-mtl >=0.2+ , microlens-th >=0.4 , mtl >=2.2 , text >=1.2 , unliftio >=0.2+ , unliftio-core >=0.1 , unordered-containers >=0.2 , wai >=3.2 default-language: Haskell2010
src/Infernal.hs view
@@ -23,19 +23,31 @@ , runSimpleLambda ) where +import Control.Exception (Exception, SomeException, fromException) import Control.Monad (forever, void)-import Data.Aeson (eitherDecode, encode, pairs, (.=))+import Control.Monad.Catch (MonadCatch (..), MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (UnliftIO (..), askUnliftIO)+import Control.Monad.Reader (MonadReader)+import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode, pairs, (.=)) import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI+import Data.Hashable (Hashable) import Data.Maybe (isJust)+import Data.String (IsString)+import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Heart.App.App (App, newApp)-import Heart.App.Logging (HasSimpleLog (..), SimpleLogAction, WithSimpleLog, logDebug, logError, logException)-import Heart.Core.Prelude-import Heart.Core.RIO (RIO, runRIO)+import GHC.Generics (Generic)+import Infernal.Internal.App (App, newApp)+import Infernal.Internal.Logging (HasSimpleLog (..), SimpleLogAction, WithSimpleLog, logDebug, logError, logException)+import Infernal.Internal.RIO (RIO, runRIO)+import Lens.Micro (Lens')+import Lens.Micro.Mtl (view)+import Lens.Micro.TH (makeLenses) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Types as HT+import Prelude import System.Exit (ExitCode) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) import Text.Read (readMaybe)@@ -66,7 +78,7 @@ data LambdaError = LambdaError { _lerrErrorType :: !Text -- ^ The type of error that occurred. In this library is is often @StartCase@-formated. , _lerrErrorMessage :: !Text -- ^ A useful error message- } deriving stock (Eq, Show, Typeable, Generic)+ } deriving stock (Eq, Show, Generic) instance Exception LambdaError @@ -390,6 +402,6 @@ runSimpleLambda cb = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering- app <- newApp+ let app = newApp unio <- unliftRIO app runRIO app (runLambda unio defaultInitErrorCallback (const (pure (defaultCallbackConfig cb))))
src/Infernal/Events/APIGateway.hs view
@@ -14,15 +14,18 @@ , APIGatewayProxyResponse (..) ) where -import Data.Aeson (object, withObject, (.!=), (.:), (.:?), (.=))+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=)) import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI+import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Heart.Core.Prelude+import GHC.Generics (Generic) import qualified Network.HTTP.Types as HT+import Prelude fromAWSQuery :: HashMap Text Text -> HT.Query fromAWSQuery = fmap toQueryItem . HashMap.toList where
+ src/Infernal/Internal/App.hs view
@@ -0,0 +1,20 @@+{-| A basic app wrapper. -}+module Infernal.Internal.App+ ( App (..)+ , newApp+ ) where++import Infernal.Internal.Logging (HasSimpleLog (..), SimpleLogAction, defaultSimpleLogAction)+import Lens.Micro.TH (makeLenses)++newtype App = App+ { _appLogAction :: SimpleLogAction+ }++$(makeLenses ''App)++instance HasSimpleLog App where+ simpleLogL = appLogAction++newApp :: App+newApp = App defaultSimpleLogAction
+ src/Infernal/Internal/Logging.hs view
@@ -0,0 +1,61 @@+{-| Basic logging based on co-log. -}+module Infernal.Internal.Logging+ ( SimpleLogAction+ , HasSimpleLog (..)+ , WithSimpleLog+ , defaultSimpleLogAction+ , logMsg+ , log+ , logDebug+ , logInfo+ , logWarning+ , logError+ , logException+ ) where++import Colog.Actions (richMessageAction)+import Colog.Core.Action (LogAction (..))+import Colog.Core.Severity (Severity (..))+import Colog.Message (Message, Msg (..))+import Control.Exception (Exception, displayException)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..))+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)+import Lens.Micro (Lens')+import Lens.Micro.Mtl (view)+import Prelude hiding (log)++type SimpleLogAction = LogAction IO Message++class HasSimpleLog env where+ simpleLogL :: Lens' env SimpleLogAction++type WithSimpleLog env m = (MonadIO m, MonadReader env m, HasSimpleLog env, HasCallStack)++defaultSimpleLogAction :: SimpleLogAction+defaultSimpleLogAction = richMessageAction++logMsg :: WithSimpleLog env m => Message -> m ()+logMsg msg = do+ LogAction act <- view simpleLogL+ liftIO (act msg)++log :: WithSimpleLog env m => Severity -> Text -> m ()+log sev txt = withFrozenCallStack (logMsg Msg { msgStack = callStack, msgSeverity = sev, msgText = txt })++logDebug :: WithSimpleLog env m => Text -> m ()+logDebug = withFrozenCallStack (log Debug)++logInfo :: WithSimpleLog env m => Text -> m ()+logInfo = withFrozenCallStack (log Info)++logWarning :: WithSimpleLog env m => Text -> m ()+logWarning = withFrozenCallStack (log Warning)++logError :: WithSimpleLog env m => Text -> m ()+logError = withFrozenCallStack (log Error)++logException :: forall e m env . (WithSimpleLog env m, Exception e) => e -> m ()+logException = withFrozenCallStack (logError . Text.pack . displayException)
+ src/Infernal/Internal/RIO.hs view
@@ -0,0 +1,24 @@+-- {-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE FunctionalDependencies #-}+-- {-# LANGUAGE UndecidableInstances #-}++{- |+Most definitions follow the RIO lib: https://hackage.haskell.org/package/rio-0.1.14.0/docs/RIO.html+See LICENSE info in the README.+-}+module Infernal.Internal.RIO+ ( RIO+ , runRIO+ ) where++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Reader (MonadReader, ReaderT (..))+import Prelude++newtype RIO env a = RIO { unRIO :: ReaderT env IO a }+ deriving (Functor, Applicative, Monad, MonadReader env, MonadIO, MonadThrow, MonadFail, MonadCatch, MonadMask, MonadUnliftIO)++runRIO :: MonadIO m => env -> RIO env a -> m a+runRIO r m = liftIO (runReaderT (unRIO m) r)
src/Infernal/Wai.hs view
@@ -11,18 +11,20 @@ ) where import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary.Builder (Builder, toLazyByteString) import qualified Data.ByteString as ByteString import Data.ByteString.Lazy (toStrict) import Data.IORef (modifyIORef', newIORef, readIORef) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8)-import Heart.App.Logging (WithSimpleLog, logDebug)-import Heart.Core.Prelude import Infernal (RunCallback, decodeRequest, encodeResponse, runSimpleLambda) import Infernal.Events.APIGateway (APIGatewayProxyRequest (..), APIGatewayProxyResponse (..))+import Infernal.Internal.Logging (WithSimpleLog, logDebug) import Network.Wai (Application, Response, StreamingBody, defaultRequest, responseToStream) import Network.Wai.Internal (Request (..), ResponseReceived (..))+import Prelude -- | Turn an 'APIGatewayProxyRequest' into a WAI 'Request'. (Not all fields will be present!) adaptRequest :: APIGatewayProxyRequest -> Request@@ -33,7 +35,7 @@ , pathInfo = dropWhile Text.null (Text.split (=='/') (decodeUtf8 (_agprqPath proxyReq))) , queryString = _agprqQueryStringParameters proxyReq , requestHeaders = _agprqHeaders proxyReq- , requestBody = maybe empty pure (_agprqBody proxyReq)+ , requestBody = maybe mempty pure (_agprqBody proxyReq) } consumeStream :: StreamingBody -> IO Builder