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.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 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 diff --git a/src/Infernal.hs b/src/Infernal.hs --- a/src/Infernal.hs +++ b/src/Infernal.hs @@ -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)))) diff --git a/src/Infernal/Events/APIGateway.hs b/src/Infernal/Events/APIGateway.hs --- a/src/Infernal/Events/APIGateway.hs +++ b/src/Infernal/Events/APIGateway.hs @@ -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 diff --git a/src/Infernal/Internal/App.hs b/src/Infernal/Internal/App.hs new file mode 100644 --- /dev/null +++ b/src/Infernal/Internal/App.hs @@ -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 diff --git a/src/Infernal/Internal/Logging.hs b/src/Infernal/Internal/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Infernal/Internal/Logging.hs @@ -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) diff --git a/src/Infernal/Internal/RIO.hs b/src/Infernal/Internal/RIO.hs new file mode 100644 --- /dev/null +++ b/src/Infernal/Internal/RIO.hs @@ -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) diff --git a/src/Infernal/Wai.hs b/src/Infernal/Wai.hs --- a/src/Infernal/Wai.hs +++ b/src/Infernal/Wai.hs @@ -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