{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Cardano.Rpc.Server.Internal.Monad
  ( Has (..)
  , MonadRpc
  , grab
  , putTrace
  , wrapInSpan
  )
where

import Cardano.Api
import Cardano.Rpc.Server.Internal.Env
import Cardano.Rpc.Server.Internal.Tracing

import RIO

import Control.Tracer (Tracer, traceWith)
import System.Random.Stateful (globalStdGen, uniformM)

-- | Provides a value of type 'field' from the value 'env'
-- Used in conjunction with 'MonadReader env m' allows to easily access fields from the environment.
class Has field env where
  obtain :: env -> field

instance Has a a where
  obtain :: a -> a
obtain = a -> a
forall a. a -> a
id

instance Has LocalNodeConnectInfo RpcEnv where
  obtain :: RpcEnv -> LocalNodeConnectInfo
obtain RpcEnv{LocalNodeConnectInfo
rpcLocalNodeConnectInfo :: LocalNodeConnectInfo
rpcLocalNodeConnectInfo :: RpcEnv -> LocalNodeConnectInfo
rpcLocalNodeConnectInfo} = LocalNodeConnectInfo
rpcLocalNodeConnectInfo

instance MonadIO m => Has (Tracer m TraceRpc) RpcEnv where
  obtain :: RpcEnv -> Tracer m TraceRpc
obtain RpcEnv{forall (m :: * -> *). MonadIO m => Tracer m TraceRpc
tracer :: forall (m :: * -> *). MonadIO m => Tracer m TraceRpc
tracer :: RpcEnv -> forall (m :: * -> *). MonadIO m => Tracer m TraceRpc
tracer} = Tracer m TraceRpc
forall (m :: * -> *). MonadIO m => Tracer m TraceRpc
tracer

-- | Obtain the field from the environment
grab
  :: forall field env m
   . (Has field env, MonadReader env m)
  => m field
grab :: forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab = (env -> field) -> m field
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((env -> field) -> m field) -> (env -> field) -> m field
forall a b. (a -> b) -> a -> b
$ forall field env. Has field env => env -> field
obtain @field
{-# INLINE grab #-}

-- | Using tracer from the environment, print the trace
putTrace
  :: forall t' t e m
   . t ~ TraceRpc
  => Inject t' t
  => Has (Tracer m t) e
  => MonadReader e m
  => t'
  -- ^ the traced value
  -> m ()
putTrace :: forall t' t e (m :: * -> *).
(t ~ TraceRpc, Inject t' t, Has (Tracer m t) e, MonadReader e m) =>
t' -> m ()
putTrace t'
t' = forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab @(Tracer m t) m (Tracer m t) -> (Tracer m t -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Tracer m t -> t -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
`traceWith` t' -> t
forall t s. Inject t s => t -> s
inject t'
t')
{-# INLINE putTrace #-}

-- | Wrap the action in span begin and end events
wrapInSpan
  :: forall t' t e m a
   . t ~ TraceRpc
  => Inject t' t
  => NFData a
  => Has (Tracer m t) e
  => MonadReader e m
  => MonadUnliftIO m
  => (TraceSpanEvent -> t')
  -- ^ Trace constructor accepting 'TraceSpanEvent'
  -> m a
  -- ^ action to be wrapped in begin and end events
  -> m a
wrapInSpan :: forall t' t e (m :: * -> *) a.
(t ~ TraceRpc, Inject t' t, NFData a, Has (Tracer m t) e,
 MonadReader e m, MonadUnliftIO m) =>
(TraceSpanEvent -> t') -> m a -> m a
wrapInSpan TraceSpanEvent -> t'
spanConstructor m a
act = do
  spanId <- m SpanId
newSpanId
  putTrace $ spanConstructor (SpanBegin spanId)
  (act >>= (evaluate . force)) `finally` putTrace (spanConstructor $ SpanEnd spanId)
 where
  -- generate random span id
  newSpanId :: m SpanId
  newSpanId :: m SpanId
newSpanId = Word64 -> SpanId
forall a. a -> UsingRawBytesHex a
UsingRawBytesHex (Word64 -> SpanId) -> m Word64 -> m SpanId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AtomicGenM StdGen -> m Word64
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
forall g (m :: * -> *). StatefulGen g m => g -> m Word64
uniformM AtomicGenM StdGen
globalStdGen
{-# INLINE wrapInSpan #-}

type MonadRpc e m =
  ( Has (Tracer m TraceRpc) e
  , Has LocalNodeConnectInfo e
  , HasCallStack
  , MonadReader e m
  , MonadUnliftIO m
  )