Handle.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Description : EventBackend for rendering events as JSON to a handle
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Observe.Event.Render.JSON.Handle
  ( jsonHandleBackend,
    simpleJsonStderrBackend,

    -- * Internals
    JSONRef (..),
    newJSONEvent,
  )
where

import Control.Concurrent.MVar
import Control.Exception
import Data.Aeson
import Data.Aeson.KeyMap (insert)
import Data.ByteString.Lazy.Char8 (hPutStrLn)
import Data.Coerce
import Data.IORef
import Data.Time.Clock
import Data.UUID (UUID)
import Data.UUID.V4
import Observe.Event
import Observe.Event.Backend
import Observe.Event.Render.JSON
import System.IO (Handle, stderr)

-- | The reference type for 'EventBackend's generated by 'jsonHandleBackend'.
--
-- Only expected to be used by type inference or by code implementing other backends
-- using this one.
newtype JSONRef = JSONRef UUID deriving newtype (ToJSON)

-- | Create a new 'Event' in a 'jsonHandleBackend'.
newJSONEvent ::
  (Exception stex) =>
  -- | Emit the final 'Object'. This will be called at most once.
  (Object -> IO ()) ->
  RenderExJSON stex ->
  RenderFieldJSON f ->
  IO (Event IO JSONRef f)
newJSONEvent emit renderEx renderField = do
  eventRef <- coerce nextRandom
  start <- getCurrentTime
  fieldsRef <- newIORef mempty
  parentsRef <- newIORef mempty
  proximatesRef <- newIORef mempty
  finishOnce <- newEmptyMVar
  let finish r =
        tryPutMVar finishOnce () >>= \case
          False -> pure ()
          True -> do
            end <- getCurrentTime
            fields <- readIORef fieldsRef
            parents <- readIORef parentsRef
            proximates <- readIORef proximatesRef
            emit
              ( "event-id" .= eventRef
                  <> "start" .= start
                  <> "end" .= end
                  <> "duration" .= diffUTCTime end start
                  <> ifNotNull "fields" fields
                  <> ifNotNull "parents" parents
                  <> ifNotNull "proximate-causes" proximates
                  <> case r of
                    StructuredFail e -> "structured-exception" .= renderEx e
                    UnstructuredFail e -> "unstructured-exception" .= show e
                    Finalized -> mempty
              )
  pure $
    Event
      { reference = eventRef,
        addField = \field ->
          atomicModifyIORef' fieldsRef \fields ->
            (uncurry insert (renderField field) fields, ()),
        addReference = \(Reference ty r) ->
          let refsRef = case ty of
                Parent -> parentsRef
                Proximate -> proximatesRef
           in atomicModifyIORef' refsRef \refs -> (r : refs, ()),
        finalize = \me -> finish $ case me of
          Just e -> case fromException e of
            Just se -> StructuredFail se
            Nothing -> UnstructuredFail e
          Nothing -> Finalized
      }

-- | An 'EventBackend' which posts events to a given 'Handle' as JSON.
--
-- Each 'Event' is posted as a single line, as it's completed. As a result, child events
-- will typically be posted __before__ their parents (though still possible to correlate via
-- event IDs).
--
-- The 'EventBackend' must be the exclusive writer to the 'Handle' while any events are live,
-- but it does not 'System.IO.hClose' it itself.
jsonHandleBackend ::
  -- The type of structured exceptions
  (Exception stex) =>
  -- | Where to write 'Event's.
  Handle ->
  -- | Render a structured exception to JSON
  RenderExJSON stex ->
  -- | Render a selector, and the fields of 'Event's selected by it, to JSON
  RenderSelectorJSON s ->
  IO (EventBackend IO JSONRef s)
jsonHandleBackend h renderEx renderSel = do
  outputLock <- newMVar ()
  let emit :: Object -> IO ()
      emit o = withMVar outputLock \() ->
        hPutStrLn h $ encode o
  pure $
    EventBackend
      { newEvent = \sel -> do
          let (k, renderField) = renderSel sel
          newJSONEvent (emit . (k .=)) renderEx renderField
      }

-- | An 'EventBackend' which posts events to @stderr@ as JSON.
--
-- Each 'Event' is posted as a single line, as it's completed. As a result, child events
-- will typically be posted __before__ their parents (though still possible to correlate via
-- event IDs).
--
-- Any instrumented 'Exception's descended from 'SomeJSONException' will be structurally rendered.
--
-- The 'EventBackend' must be the exclusive writer to @stderr@ while any events are live,
-- but it does not 'System.IO.hClose' it itself.
simpleJsonStderrBackend :: RenderSelectorJSON s -> IO (EventBackend IO JSONRef s)
simpleJsonStderrBackend = jsonHandleBackend stderr (toJSON @SomeJSONException)

-- | Why did an 'Event' finish?
data FinishReason stex
  = StructuredFail stex
  | UnstructuredFail SomeException
  | Finalized

-- | Add k .= v if v is not 'null'.
ifNotNull :: (Foldable f, ToJSON (f v)) => Key -> f v -> Object
ifNotNull k v = if null v then mempty else k .= v