eventuo11y-batteries (empty) → 0.1.0.0
raw patch · 6 files changed
+485/−0 lines, 6 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, binary, bytestring, case-insensitive, containers, eventuo11y, exceptions, http-media, http-types, monad-control, mtl, network, semigroupoids, servant-client, servant-client-core, text, transformers-base, unliftio-core, wai, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +13/−0
- eventuo11y-batteries.cabal +53/−0
- src/Observe/Event/Crash.hs +79/−0
- src/Observe/Event/Servant/Client.hs +187/−0
- src/Observe/Event/Wai.hs +148/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for eventuo11y-batteries++## 0.1.0.0 -- 2022-09-28++Initial release
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2022 Shea Levy.++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this project except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ eventuo11y-batteries.cabal view
@@ -0,0 +1,53 @@+cabal-version: 3.0+name: eventuo11y-batteries+version: 0.1.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.++bug-reports: https://github.com/shlevy/eventuo11y/issues+license: Apache-2.0+license-file: LICENSE+author: Shea Levy+maintainer: shea@shealevy.com+copyright: Copyright 2022 Shea Levy.+category: Observability+extra-source-files: CHANGELOG.md+tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.2++source-repository head+ type: git+ location: https://github.com/shlevy/eventuo11y++library+ exposed-modules:+ Observe.Event.Crash+ Observe.Event.Servant.Client+ Observe.Event.Wai++ build-depends:+ , aeson ^>=2.0.3.0+ , async ^>=2.2.4+ , base >=4.14 && <4.17+ , binary ^>=0.8+ , bytestring >=0.10.12.0 && <0.12+ , case-insensitive ^>=1.2.1.0+ , containers ^>=0.6+ , eventuo11y ^>=0.1.0.0+ , exceptions ^>=0.10.4+ , http-media ^>=0.8.0.0+ , http-types ^>=0.12.3+ , monad-control ^>=1.0.3.1+ , mtl ^>=2.2.2+ , network ^>=3.1.2.7+ , semigroupoids ^>=5.3.7+ , servant-client ^>=0.19+ , servant-client-core ^>=0.19+ , text ^>=1.2.5.0+ , transformers-base ^>=0.4.6+ , unliftio-core ^>=0.2.0.1+ , wai ^>=3.2.3+ , warp ^>=3.3.19++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Observe/Event/Crash.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- 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.Concurrent.Async+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Unlift+import Data.Void+import Observe.Event+import Observe.Event.Render.JSON++-- | Run an action with a 'ScheduleCrash' that can be called to crash the application.+withScheduleCrash ::+ (MonadUnliftIO m) =>+ EventBackend m r Crashing ->+ -- | Actually perform the crash.+ DoCrash m ->+ (ScheduleCrash m r -> m a) ->+ m a+withScheduleCrash backend crash go = withRunInIO $ \runInIO -> do+ scheduleCrashChan <- newEmptyMVar+ let waitForCrash = do+ cause <- takeMVar scheduleCrashChan+ withEvent (hoistEventBackend runInIO backend) Crashing \ev ->+ maybe+ (pure ())+ (addProximate ev)+ cause+ runInIO crash+ withAsync waitForCrash \_ ->+ runInIO $ go $ void . liftIO . tryPutMVar scheduleCrashChan++-- | Function to schedule an application crash, perhaps caused by a referenced 'Event'.+type ScheduleCrash m r = Maybe 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 s = nt . s++-- | 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)
+ src/Observe/Event/Servant/Client.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Description : Instrument servant-client with eventuo11y+-- Copyright : Copyright 2022 Shea Levy.+-- License : Apache-2.0+-- Maintainer : shea@shealevy.com+--+-- This module offers a variant of servant-client's 'S.ClientM' which instruments+-- all requests with 'Event's. It also has miscellaneous helpers for instrumenting+-- servant-client functionality in other ways.+module Observe.Event.Servant.Client+ ( -- * ClientM+ ClientM (..),+ runClientM,++ -- ** Instrumentation+ RunRequest (..),+ runRequestJSON,+ RunRequestField (..),+ runRequestFieldJSON,++ -- * Miscellaneous instrumentation+ clientErrorJSON,+ responseJSON,+ )+where++import Control.Monad.Base+import Control.Monad.Catch+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.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)++ some x = ClientM $ ReaderT \backend -> some (runReaderT (coerce x) backend)+ many x = ClientM $ ReaderT \backend -> many (runReaderT (coerce x) backend)++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+ pure res+ throwClientError = ClientM . lift . throwClientError++-- | 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)++-- | Selector for events in 'ClientM'+data RunRequest f where+ RunRequest :: RunRequest RunRequestField++-- | Render a 'RunRequest' and the fields of its selected events as JSON+runRequestJSON :: RenderSelectorJSON RunRequest+runRequestJSON RunRequest = ("run-request", runRequestFieldJSON)++-- | A field for v'RunRequest' events.+data RunRequestField+ = ReqField Request+ | ResField Response++-- | Render a 'RunRequestField' as JSON.+runRequestFieldJSON :: RenderFieldJSON RunRequestField+runRequestFieldJSON (ReqField Request {..}) =+ ( "request",+ Object+ ( "path" .= decodeUtf8 (toStrict $ toLazyByteString requestPath)+ <> ( if null requestQueryString+ then mempty+ else+ "query"+ .= ( ( \(k, mv) ->+ Object+ ( "key" .= decodeUtf8 k+ <> maybe mempty (("value" .=) . decodeUtf8) mv+ )+ )+ <$> requestQueryString+ )+ )+ <> case requestBody of+ Nothing -> mempty+ Just (body, ty) ->+ ( "content-type" .= decodeUtf8 (renderHeader ty)+ <> case body of+ RequestBodyBS bs -> "body" .= decodeUtf8 bs+ RequestBodyLBS Empty -> "body" .= False+ RequestBodyLBS (Chunk bs Empty) -> "body" .= decodeUtf8 bs+ _ -> mempty+ )+ <> ( if null requestAccept+ then mempty+ else "accept" .= fmap (decodeUtf8 . renderHeader) requestAccept+ )+ <> ( if null requestHeaders+ then mempty+ else "headers" .= fmap (\(nm, val) -> Object ("name" .= decodeUtf8 (original nm) <> (if nm == "Authorization" then mempty else "val" .= decodeUtf8 val))) requestHeaders+ )+ <> "http-version" .= Object ("major" .= httpMajor requestHttpVersion <> "minor" .= httpMinor requestHttpVersion)+ <> "method" .= decodeUtf8 requestMethod+ )+ )+runRequestFieldJSON (ResField res) =+ ( "response",+ responseJSON res False+ )++-- | Render a 'ClientError', considered as an 'Event' field, as JSON+clientErrorJSON :: RenderFieldJSON ClientError+clientErrorJSON (FailureResponse _ res) = ("failure-response", responseJSON res True)+clientErrorJSON (DecodeFailure err res) = ("decode-failure", Object ("response" .= responseJSON res True <> "err" .= String err))+clientErrorJSON (UnsupportedContentType ty res) =+ ( "unsupported-content-type",+ Object+ ( "response" .= responseJSON res True+ <> "main-type" .= decodeUtf8 (original $ mainType ty)+ <> "sub-type" .= decodeUtf8 (original $ subType ty)+ <> "parameters" .= fmap (decodeUtf8 . original) (mapKeys (decodeUtf8 . original) $ parameters ty)+ )+ )+clientErrorJSON (InvalidContentTypeHeader res) = ("invalid-content-type-header", responseJSON res True)+clientErrorJSON (ConnectionError e) = ("connection-error", toJSON $ show e)++-- | Render a 'Servant.Client.Core.Response' as JSON, optionally forcing rendering the body even if it's large.+responseJSON :: Response -> Bool -> Value+responseJSON Response {..} forceBody =+ Object+ ( "status" .= statusCode responseStatusCode+ <> ( if null responseHeaders+ then mempty+ else "headers" .= fmap (\(nm, val) -> Object ("name" .= decodeUtf8 (original nm) <> (if nm == "Cookie" then mempty else "val" .= decodeUtf8 val))) responseHeaders+ )+ <> "http-version" .= Object ("major" .= httpMajor responseHttpVersion <> "minor" .= httpMinor responseHttpVersion)+ <> ( if forceBody+ then "body" .= (decodeUtf8 $ toStrict responseBody)+ else case responseBody of+ Empty -> "body" .= False+ Chunk bs Empty -> "body" .= decodeUtf8 bs+ _ -> mempty+ )+ )
+ src/Observe/Event/Wai.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Description : Instrument wai with eventuo11y+-- Copyright : Copyright 2022 Shea Levy.+-- License : Apache-2.0+-- Maintainer : shea@shealevy.com+module Observe.Event.Wai+ ( -- * Application+ application,++ -- ** Instrumentation+ ServeRequest (..),+ renderServeRequest,+ RequestField (..),+ renderRequestField,++ -- * setOnException+ onExceptionCallback,++ -- ** Instrumentation+ OnException (..),+ renderOnException,+ OnExceptionField (..),+ renderOnExceptionField,++ -- * Miscellaneous instrumentation+ renderRequest,+ )+where++import Control.Exception+import Data.Aeson+import Data.CaseInsensitive+import Data.Text.Encoding+import Network.HTTP.Types.Status+import Network.HTTP.Types.Version+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Internal+import Observe.Event+import Observe.Event.Render.JSON++-- | 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++-- | Event selector for 'application'.+data ServeRequest f where+ ServeRequest :: ServeRequest RequestField++-- | Render a 'ServeRequest', and any 'Event's selected by it, to JSON+renderServeRequest :: RenderSelectorJSON ServeRequest+renderServeRequest ServeRequest = ("serve-request", renderRequestField)++-- | A field for v'ServeRequest' 'Event's.+data RequestField+ = ReqField Request+ | ResField Response++-- | Render a 'RequestField' to JSON+renderRequestField :: RenderFieldJSON RequestField+renderRequestField (ReqField req) =+ ( "request",+ renderRequest req+ )+renderRequestField (ResField res) = ("response-status" .= (statusCode $ responseStatus res))++-- | A 'Network.Wai.Handler.Warp.setOnException' callback which creates an 'Event' rendering+-- 'Exception's.+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 ()++-- | Selector for 'Observe.Event.Wai.onException'+data OnException f where+ OnException :: OnException OnExceptionField++-- | Render an 'OnException', and its selected-for 'Event's, as JSON, with a provided base structured exception type.+renderOnException :: (Exception stex) => RenderExJSON stex -> RenderSelectorJSON OnException+renderOnException renderEx OnException = ("on-exception", renderOnExceptionField renderEx)++-- | A field for a v'OnException' 'Event'.+data OnExceptionField = OnExceptionField (Maybe Request) SomeException++-- | Render an 'OnExceptionField' as JSON, with a provided base structured exception type.+renderOnExceptionField :: (Exception stex) => RenderExJSON stex -> RenderFieldJSON OnExceptionField+renderOnExceptionField renderEx (OnExceptionField mreq e) =+ ( "uncaught-exception",+ Object+ ( maybe mempty (("request" .=) . renderRequest) mreq+ <> maybe ("unstructured-exception" .= show e) (("structured-exception" .=) . renderEx) (fromException e)+ )+ )++-- | Render a 'Request' to JSON.+renderRequest :: Request -> Value+renderRequest (Request {..}) =+ Object+ ( "remote-addr" .= Object case remoteHost of+ SockAddrInet port addr ->+ ( "port" .= toInteger port+ <> "addr" .= hostAddressToTuple addr+ )+ SockAddrInet6 port flow addr scope ->+ ( "port" .= toInteger port+ <> "flow" .= flow+ <> "addr" .= hostAddress6ToTuple addr+ <> "scope" .= scope+ )+ SockAddrUnix path -> "path" .= path+ <> "method" .= decodeUtf8 requestMethod+ <> "http-version" .= Object ("major" .= httpMajor httpVersion <> "minor" .= httpMinor httpVersion)+ <> "path" .= pathInfo+ <> "query"+ .= fmap+ ( \(k, mv) ->+ Object+ ( "param" .= decodeUtf8 k <> case mv of+ Just v -> "value" .= decodeUtf8 v+ Nothing -> mempty+ )+ )+ queryString+ <> ( case requestBodyLength of+ ChunkedBody -> mempty+ KnownLength l -> "length" .= l+ )+ <> ( if null requestHeaders+ then mempty+ else "headers" .= fmap (\(nm, val) -> Object ("name" .= decodeUtf8 (original nm) <> (if nm == "Authorization" then mempty else "val" .= decodeUtf8 val))) requestHeaders+ )+ )