diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for eventuo11y-batteries + +## 0.1.0.0 -- 2022-09-28 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/eventuo11y-batteries.cabal b/eventuo11y-batteries.cabal new file mode 100644 --- /dev/null +++ b/eventuo11y-batteries.cabal @@ -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 diff --git a/src/Observe/Event/Crash.hs b/src/Observe/Event/Crash.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Crash.hs @@ -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) diff --git a/src/Observe/Event/Servant/Client.hs b/src/Observe/Event/Servant/Client.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Servant/Client.hs @@ -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 + ) + ) diff --git a/src/Observe/Event/Wai.hs b/src/Observe/Event/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Wai.hs @@ -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 + ) + )