eventuo11y-batteries 0.2.1.1 → 0.3.0.0

raw patch · 5 files changed

+85/−132 lines, 5 filesdep +general-allocatedep +unliftio-coredep ~aesondep ~basedep ~eventuo11yPVP ok

version bump matches the API change (PVP)

Dependencies added: general-allocate, unliftio-core

Dependency ranges changed: aeson, base, eventuo11y, eventuo11y-json, mtl, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• eventuo11y-batteries.cabal +9/−8
• src/Observe/Event/Crash.hs +0/−73
• src/Observe/Event/Servant/Client.hs +26/−33
• src/Observe/Event/Wai.hs +43/−17

@@ -1,6 +1,12 @@ # Revision history for eventuo11y-batteries -## 0.2.1.0 -- 2022-10-23+## 0.3.0.0 -- 2022-12-23++- Update for eventuo11y 0.6+- Update for eventu11y-json 0.2+- Remove Observe.Event.Crash++## 0.2.1.1 -- 2022-10-23  Update for eventu11y 0.5.0.0 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               eventuo11y-batteries-version:            0.2.1.1+version:            0.3.0.0 synopsis:           Grab bag of eventuo11y-enriched functionality description:   Miscellaneous helpers for instrumenting with [eventuo11y](https://hackage.haskell.org/package/eventuo11y) and 3rd-party packages.@@ -21,30 +21,31 @@  library   exposed-modules:-    Observe.Event.Crash     Observe.Event.Servant.Client     Observe.Event.Wai    build-depends:-    , base                 ^>= { 4.14, 4.16 }-    , aeson                ^>= 2.0+    , base                 ^>= { 4.14, 4.16, 4.17 }+    , aeson                ^>= { 2.0, 2.1 }     , binary               ^>= 0.8     , bytestring           ^>= { 0.10, 0.11 }     , case-insensitive     ^>= 1.2     , containers           ^>= 0.6-    , eventuo11y           ^>= 0.5-    , eventuo11y-json      ^>= 0.1+    , eventuo11y           ^>= 0.6+    , eventuo11y-json      ^>= { 0.2 }+    , general-allocate     ^>= { 0.2 }     , http-media           ^>= 0.8     , http-types           ^>= 0.12     , monad-control        ^>= 1.0-    , mtl                  ^>= 2.2+    , mtl                  ^>= { 2.2, 2.3 }     , network              ^>= 3.1     , safe-exceptions      ^>= 0.1     , semigroupoids        ^>= 5.3     , servant-client       ^>= 0.19     , servant-client-core  ^>= 0.19-    , text                 ^>= 1.2+    , text                 ^>= { 1.2, 2.0 }     , transformers-base    ^>= 0.4+    , unliftio-core        ^>= { 0.2 }     , wai                  ^>= 3.2     , warp                 ^>= 3.3 

@@ -1,73 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}---- |--- Description : Combine eventuo11y instrumentation with crash-only designs.--- Copyright   : Copyright 2022 Shea Levy.--- License     : Apache-2.0--- Maintainer  : shea@shealevy.com------ This module contains helpers to use eventuo11y to instrument crashes in a--- crash-only application design, where it is insufficient to simply crash in--- a top-level exception handler. For example, a "Network.Wai.Handler.Warp"--- server may want to crash in its 'Network.Wai.Handler.Warp.setOnException'--- callback, but only when the exception is due to a server-side issue and only--- after all open requests have been serviced.-module Observe.Event.Crash-  ( withScheduleCrash,-    ScheduleCrash (..),-    DoCrash,-    hoistScheduleCrash,--    -- * Instrumentation-    Crashing (..),-    renderCrashing,-  )-where--import Control.Monad.Cleanup-import Data.Void-import Observe.Event-import Observe.Event.BackendModification-import Observe.Event.Render.JSON---- | Run an action with a 'ScheduleCrash' that can be called to crash the application.-withScheduleCrash ::-  (MonadCleanup m) =>-  EventBackend m r Crashing ->-  -- | Actually perform the crash.-  DoCrash m ->-  (ScheduleCrash m r -> m a) ->-  m a-withScheduleCrash backend crash go =-  go $ ScheduleCrash \mods ->-    let backend' = modifyEventBackend mods backend-     in withEvent backend' Crashing $ const crash---- | Function to schedule an application crash.-newtype ScheduleCrash m r = ScheduleCrash-  { -- | Schedule a crash-    schedule :: forall r'. EventBackendModifiers r r' -> m ()-  }---- | Function to actually initiate the crash.-type DoCrash m = m ()---- | Hoist a 'ScheduleCrash' along a given natural transformation into a new functor.-hoistScheduleCrash ::-  -- | Natural transformation from @f@ to @g@.-  (forall x. f x -> g x) ->-  ScheduleCrash f r ->-  ScheduleCrash g r-hoistScheduleCrash nt (ScheduleCrash {..}) = ScheduleCrash $ nt . schedule---- | Event selector for 'withScheduleCrash'.-data Crashing f where-  Crashing :: Crashing Void---- | Render a 'Crashing' and its sub-events to JSON.-renderCrashing :: RenderSelectorJSON Crashing-renderCrashing Crashing = ("crashing", absurd)

@@ -1,12 +1,18 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  -- | -- Description : Instrument servant-client with eventuo11y@@ -19,7 +25,8 @@ -- servant-client functionality in other ways. module Observe.Event.Servant.Client   ( -- * ClientM-    ClientM (..),+    ClientM,+    ClientEnv (..),     runClientM,      -- ** Instrumentation@@ -34,63 +41,49 @@   ) where -import Control.Exception.Safe-import Control.Monad.Base import Control.Monad.Except import Control.Monad.Reader-import Control.Monad.Trans.Control import Data.Aeson import Data.Binary.Builder import Data.ByteString.Lazy hiding (null) import Data.ByteString.Lazy.Internal (ByteString (..)) import Data.CaseInsensitive import Data.Coerce-import Data.Functor.Alt import Data.Map.Strict (mapKeys) import Data.Text.Encoding-import GHC.Generics import Network.HTTP.Media.MediaType import Network.HTTP.Media.RenderHeader import Network.HTTP.Types.Status import Network.HTTP.Types.Version import Observe.Event import Observe.Event.Render.JSON-import Servant.Client hiding (ClientM, runClientM)+import Servant.Client hiding (ClientEnv, ClientM, runClientM)+import qualified Servant.Client as S import Servant.Client.Core.Request import Servant.Client.Core.RunClient hiding (RunRequest)-import Servant.Client.Internal.HttpClient hiding (ClientM, runClientM)-import qualified Servant.Client.Internal.HttpClient as S  -- | A monad to use in place of 'S.ClientM' to get instrumentation on requests.-newtype ClientM r a = ClientM (ReaderT (EventBackend S.ClientM r RunRequest) S.ClientM a)-  deriving newtype (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadError ClientError, MonadBase IO, MonadReader (EventBackend S.ClientM r RunRequest))-  deriving stock (Generic)--instance MonadBaseControl IO (ClientM r) where-  type StM (ClientM r) a = Either ClientError a--  liftBaseWith go = ClientM $ ReaderT \backend -> liftBaseWith (\run -> go (run . flip runReaderT backend . coerce))-  restoreM = ClientM . lift . restoreM--instance Alt (ClientM r) where-  x <!> y = ClientM $ ReaderT \backend -> (runReaderT (coerce x) backend) <!> (runReaderT (coerce y) backend)+type ClientM em r s = TransEventMonad (ReaderT (ClientEnv s)) (TransEventMonad (ExceptT ClientError) em) r s -  some x = ClientM $ ReaderT \backend -> some (runReaderT (coerce x) backend)-  many x = ClientM $ ReaderT \backend -> many (runReaderT (coerce x) backend)+-- | An instrumented 'S.ClientEnv'+data ClientEnv s = ClientEnv+  { env :: !S.ClientEnv,+    injectRunRequest :: !(InjectSelector RunRequest s)+  } -instance RunClient (ClientM r) where-  -- ClientM internals needed pending a release with https://github.com/haskell-servant/servant/commit/658585a7cd2191d1387786d236b8b64cd4a13cb6-  runRequestAcceptStatus stats req = ClientM $ ReaderT \backend -> S.ClientM $-    withEvent (hoistEventBackend unClientM backend) RunRequest \ev -> do-      addField ev $ ReqField req-      res <- unClientM $ runRequestAcceptStatus stats req-      addField ev $ ResField res+instance (MonadIO (em r s), MonadWithEvent em r s) => RunClient (ClientM em r s) where+  runRequestAcceptStatus stats req = do+    e <- ask+    injectRunRequest e RunRequest \runReq injField -> withEvent runReq \ev -> do+      addField ev . injField $ ReqField req+      res <- coerce $ const @_ @(ClientEnv s) (liftIO @(em r s) . flip S.runClientM (env e) $ runRequestAcceptStatus stats req)+      addField ev . injField $ ResField res       pure res-  throwClientError = ClientM . lift . throwClientError+  throwClientError = throwError  -- | Instrumented version of 'S.runClientM'-runClientM :: EventBackend S.ClientM r RunRequest -> ClientM r a -> ClientEnv -> IO (Either ClientError a)-runClientM backend c = S.runClientM (runReaderT (coerce c) backend)+runClientM :: ClientM em r s a -> ClientEnv s -> em r s (Either ClientError a)+runClientM = coerce  -- | Selector for events in 'ClientM' data RunRequest f where

@@ -1,8 +1,11 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeInType #-}  -- | -- Description : Instrument wai with eventuo11y@@ -11,6 +14,7 @@ -- Maintainer  : shea@shealevy.com module Observe.Event.Wai   ( -- * Application+    Application,     application,      -- ** Instrumentation@@ -20,6 +24,7 @@     renderRequestField,      -- * setOnException+    OnExceptionCallback,     onExceptionCallback,      -- ** Instrumentation@@ -34,29 +39,38 @@ where  import Control.Exception+import Control.Monad.IO.Unlift import Data.Aeson import Data.CaseInsensitive+import Data.Kind import Data.Text.Encoding import Network.HTTP.Types.Status import Network.HTTP.Types.Version import Network.Socket-import Network.Wai+import Network.Wai hiding (Application)+import qualified Network.Wai as W import Network.Wai.Handler.Warp import Network.Wai.Internal import Observe.Event+import Observe.Event.Class import Observe.Event.Render.JSON +-- | An instrumented 'W.Application'+type Application :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type+type Application em r s = Request -> (Response -> em r s ResponseReceived) -> em r s ResponseReceived+ -- | Run an 'Application' with generic 'Request'/'Response' instrumentation. application ::-  EventBackend IO r ServeRequest ->-  -- | The application, called with a reference to the parent event.-  (r -> Application) ->-  Application-application backend app req respond = withEvent backend ServeRequest \ev -> do-  addField ev $ ReqField req-  app (reference ev) req \res -> do-    addField ev $ ResField res-    respond res+  (MonadUnliftIO (em r s), MonadWithEvent em r s) =>+  InjectSelector ServeRequest s ->+  Application em r s ->+  em r s W.Application+application inj app = withRunInIO \runInIO -> pure \req respond -> runInIO $+  inj ServeRequest \serveReq injField -> withEvent serveReq \ev -> do+    addField ev . injField $ ReqField req+    app req \res -> do+      addField ev . injField $ ResField res+      liftIO $ respond res  -- | Event selector for 'application'. data ServeRequest f where@@ -79,17 +93,29 @@   ) renderRequestField (ResField res) = ("response-status" .= (statusCode $ responseStatus res)) --- | A 'Network.Wai.Handler.Warp.setOnException' callback which creates an 'Event' rendering--- 'Exception's.+-- | An instrumented 'Network.Wai.Handler.Warp.setOnException' callback.+type OnExceptionCallback :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type+type OnExceptionCallback em r s = Maybe Request -> SomeException -> em r s ()++-- | Convert an 'OnExceptionCallback' to a 'Network.Wai.Handler.Warp.setOnException' callback. --+-- The 'OnExceptionCallback' is called as the child of an 'Event' rendering the exception, if+-- it's one that should be displayed according to 'defaultShouldDisplayException'.+-- -- Ideally this would have a way to get a parent 'Event' from 'application'. Would be nice to -- use 'vault', but there doesn't seem to be a way to get at the 'Request' that Warp will pass -- here.-onExceptionCallback :: EventBackend IO r OnException -> Maybe Request -> SomeException -> IO ()-onExceptionCallback backend req e =-  if defaultShouldDisplayException e-    then withEvent backend OnException \ev -> addField ev $ OnExceptionField req e-    else pure ()+onExceptionCallback ::+  (MonadUnliftIO (em r s), MonadWithEvent em r s) =>+  InjectSelector OnException s ->+  OnExceptionCallback em r s ->+  em r s (Maybe Request -> SomeException -> IO ())+onExceptionCallback inj cb = withRunInIO \runInIO -> pure \req e -> runInIO $+  case defaultShouldDisplayException e of+    True -> inj OnException \onEx injField -> withEvent onEx \ev -> do+      addField ev . injField $ OnExceptionField req e+      cb req e+    False -> cb req e  -- | Selector for 'Observe.Event.Wai.onException' data OnException f where