{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module System.Metrics.Prometheus.Ridley.Types (
    RidleyT(Ridley)
  , Ridley
  , runRidley
  , RidleyCtx(RidleyCtx)
  , ridleyThreadId
  , ridleyWaiMetrics
  , Port
  , PrometheusOptions
  , RidleyMetric(..)
  , RidleyOptions
  , RidleyMetricHandler
  , metric
  , updateMetric
  , flush
  , label
  , mkRidleyMetricHandler
  , defaultMetrics
  , newOptions
  , prometheusOptions
  , ridleyMetrics
  , katipScribes
  , katipSeverity
  , dataRetentionPeriod
  , runHandler
  , ioLogger
  , getRidleyOptions
  , noUpdate
  ) where

import           Control.Concurrent (ThreadId)
import           Control.Monad.Catch
import           Control.Monad.IO.Class
import           Control.Monad.Reader (MonadReader)
import           Control.Monad.State.Strict
import           Control.Monad.Trans.Reader
import           Data.Time
import           GHC.Stack
import           Katip
import           Lens.Micro.TH
import           Network.Wai.Metrics (WaiMetrics)
import           System.Metrics.Prometheus.Ridley.Types.Internal
import           System.Remote.Monitoring.Prometheus
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified System.Metrics.Prometheus.MetricId as P
import qualified System.Metrics.Prometheus.RegistryT as P

--------------------------------------------------------------------------------
type Port = Int
type PrometheusOptions = AdapterOptions

mkRidleyMetricHandler :: forall c. HasCallStack
                      => T.Text
                      -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler :: forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
lbl c
c c -> Bool -> IO ()
runC Bool
flsh = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ RidleyMetricHandler {
    metric :: c
metric       = c
c
  , updateMetric :: c -> Bool -> IO ()
updateMetric = c -> Bool -> IO ()
runC
  , flush :: Bool
flush        = Bool
flsh
  , label :: Text
label        = Text
lbl
  , _cs :: CallStack
_cs          = CallStack -> CallStack
popCallStack HasCallStack => CallStack
callStack
  }

--------------------------------------------------------------------------------
data RidleyMetric = ProcessMemory
                  | CPULoad
                  | GHCConc
                  -- ^ Tap into the metrics exposed by GHC.Conc
                  | Network
                  | Wai
                  | DiskUsage
                  -- ^ Gets stats about Disk usage (free space, etc)
                  | CustomMetric !T.Text
                                 -- ^ The name of the metric
                                 !(Maybe Int)
                                 -- ^ An optional timeout, in microseconds,
                                 -- that regulates how often the metric is
                                 -- actually updated. If Nothing, the metric
                                 -- will be updated using Ridley top-level setting,
                                 -- if 'Just' the underlying 'IO' action will be run
                                 -- only every @n@ seconds, or cached otherwise.
                                 (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler)
                                 -- ^ An action to generate the handler.
                  -- ^ A user-defined metric, identified by a name.

instance Show RidleyMetric where
  show :: RidleyMetric -> String
show RidleyMetric
ProcessMemory         = String
"ProcessMemory"
  show RidleyMetric
CPULoad               = String
"CPULoad"
  show RidleyMetric
GHCConc               = String
"GHCConc"
  show RidleyMetric
Network               = String
"Network"
  show RidleyMetric
Wai                   = String
"Wai"
  show RidleyMetric
DiskUsage             = String
"DiskUsage"
  show (CustomMetric Text
name Maybe Int
_ forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
_) = String
"Custom@" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name

instance Eq RidleyMetric where
  == :: RidleyMetric -> RidleyMetric -> Bool
(==) RidleyMetric
ProcessMemory RidleyMetric
ProcessMemory             = Bool
True
  (==) RidleyMetric
CPULoad RidleyMetric
CPULoad                         = Bool
True
  (==) RidleyMetric
GHCConc RidleyMetric
GHCConc                         = Bool
True
  (==) RidleyMetric
Network RidleyMetric
Network                         = Bool
True
  (==) RidleyMetric
Wai     RidleyMetric
Wai                             = Bool
True
  (==) RidleyMetric
DiskUsage RidleyMetric
DiskUsage                     = Bool
True
  (==) (CustomMetric Text
n1 Maybe Int
_ forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
_) (CustomMetric Text
n2 Maybe Int
_ forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
_) = forall a. Eq a => a -> a -> Bool
(==) Text
n1 Text
n2
  (==) RidleyMetric
_ RidleyMetric
_                                     = Bool
False

instance Ord RidleyMetric where
  compare :: RidleyMetric -> RidleyMetric -> Ordering
compare RidleyMetric
ProcessMemory RidleyMetric
xs = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare RidleyMetric
CPULoad RidleyMetric
xs       = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare RidleyMetric
GHCConc RidleyMetric
xs       = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
LT
    RidleyMetric
GHCConc                -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare RidleyMetric
Network RidleyMetric
xs       = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
LT
    RidleyMetric
GHCConc                -> Ordering
LT
    RidleyMetric
Network                -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare RidleyMetric
Wai     RidleyMetric
xs       = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
LT
    RidleyMetric
GHCConc                -> Ordering
LT
    RidleyMetric
Network                -> Ordering
LT
    RidleyMetric
Wai                    -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare RidleyMetric
DiskUsage RidleyMetric
xs     = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
LT
    RidleyMetric
GHCConc                -> Ordering
LT
    RidleyMetric
Network                -> Ordering
LT
    RidleyMetric
Wai                    -> Ordering
LT
    RidleyMetric
DiskUsage              -> Ordering
EQ
    RidleyMetric
_                      -> Ordering
GT
  compare (CustomMetric Text
n1 Maybe Int
_ forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
_) RidleyMetric
xs = case RidleyMetric
xs of
    RidleyMetric
ProcessMemory          -> Ordering
LT
    RidleyMetric
CPULoad                -> Ordering
LT
    RidleyMetric
GHCConc                -> Ordering
LT
    RidleyMetric
Network                -> Ordering
LT
    RidleyMetric
Wai                    -> Ordering
LT
    RidleyMetric
DiskUsage              -> Ordering
LT
    (CustomMetric Text
n2 Maybe Int
_ forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
_)    -> forall a. Ord a => a -> a -> Ordering
compare Text
n1 Text
n2

--------------------------------------------------------------------------------
data RidleyOptions = RidleyOptions {
    RidleyOptions -> PrometheusOptions
_prometheusOptions :: PrometheusOptions
  , RidleyOptions -> Set RidleyMetric
_ridleyMetrics :: Set.Set RidleyMetric
  , RidleyOptions -> (Namespace, [(Text, Scribe)])
_katipScribes :: (Katip.Namespace, [(T.Text, Katip.Scribe)])
  , RidleyOptions -> Severity
_katipSeverity :: Katip.Severity
  , RidleyOptions -> Maybe NominalDiffTime
_dataRetentionPeriod :: Maybe NominalDiffTime
  -- ^ How much to retain the data, in seconds.
  -- Pass `Nothing` to not flush the metrics.
  }

makeLenses ''RidleyOptions

--------------------------------------------------------------------------------
defaultMetrics :: [RidleyMetric]
defaultMetrics :: [RidleyMetric]
defaultMetrics = [RidleyMetric
ProcessMemory, RidleyMetric
CPULoad, RidleyMetric
GHCConc, RidleyMetric
Network, RidleyMetric
Wai, RidleyMetric
DiskUsage]

--------------------------------------------------------------------------------
newOptions :: [(T.Text, T.Text)]
           -> [RidleyMetric]
           -> RidleyOptions
newOptions :: [(Text, Text)] -> [RidleyMetric] -> RidleyOptions
newOptions [(Text, Text)]
appLabels [RidleyMetric]
metrics = RidleyOptions {
    _prometheusOptions :: PrometheusOptions
_prometheusOptions = Labels -> PrometheusOptions
defaultOptions ([(Text, Text)] -> Labels
P.fromList [(Text, Text)]
appLabels)
  , _ridleyMetrics :: Set RidleyMetric
_ridleyMetrics     = forall a. Ord a => [a] -> Set a
Set.fromList [RidleyMetric]
metrics
  , _katipSeverity :: Severity
_katipSeverity     = Severity
InfoS
  , _katipScribes :: (Namespace, [(Text, Scribe)])
_katipScribes      = forall a. Monoid a => a
mempty
  , _dataRetentionPeriod :: Maybe NominalDiffTime
_dataRetentionPeriod = forall a. Maybe a
Nothing
  }

--------------------------------------------------------------------------------
runHandler :: RidleyMetricHandler -> IO ()
runHandler :: RidleyMetricHandler -> IO ()
runHandler (RidleyMetricHandler c
m c -> Bool -> IO ()
u Bool
f Text
_ CallStack
_) = c -> Bool -> IO ()
u c
m Bool
f

--------------------------------------------------------------------------------
newtype RidleyT t a = Ridley { forall (t :: * -> *) a. RidleyT t a -> ReaderT RidleyOptions t a
_unRidley :: ReaderT RidleyOptions t a }
  deriving (forall a b. a -> RidleyT t b -> RidleyT t a
forall a b. (a -> b) -> RidleyT t a -> RidleyT t b
forall (t :: * -> *) a b.
Functor t =>
a -> RidleyT t b -> RidleyT t a
forall (t :: * -> *) a b.
Functor t =>
(a -> b) -> RidleyT t a -> RidleyT t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RidleyT t b -> RidleyT t a
$c<$ :: forall (t :: * -> *) a b.
Functor t =>
a -> RidleyT t b -> RidleyT t a
fmap :: forall a b. (a -> b) -> RidleyT t a -> RidleyT t b
$cfmap :: forall (t :: * -> *) a b.
Functor t =>
(a -> b) -> RidleyT t a -> RidleyT t b
Functor, forall a. a -> RidleyT t a
forall a b. RidleyT t a -> RidleyT t b -> RidleyT t a
forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b
forall a b. RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
forall a b c.
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {t :: * -> *}. Applicative t => Functor (RidleyT t)
forall (t :: * -> *) a. Applicative t => a -> RidleyT t a
forall (t :: * -> *) a b.
Applicative t =>
RidleyT t a -> RidleyT t b -> RidleyT t a
forall (t :: * -> *) a b.
Applicative t =>
RidleyT t a -> RidleyT t b -> RidleyT t b
forall (t :: * -> *) a b.
Applicative t =>
RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
<* :: forall a b. RidleyT t a -> RidleyT t b -> RidleyT t a
$c<* :: forall (t :: * -> *) a b.
Applicative t =>
RidleyT t a -> RidleyT t b -> RidleyT t a
*> :: forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b
$c*> :: forall (t :: * -> *) a b.
Applicative t =>
RidleyT t a -> RidleyT t b -> RidleyT t b
liftA2 :: forall a b c.
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
$cliftA2 :: forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
<*> :: forall a b. RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
$c<*> :: forall (t :: * -> *) a b.
Applicative t =>
RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
pure :: forall a. a -> RidleyT t a
$cpure :: forall (t :: * -> *) a. Applicative t => a -> RidleyT t a
Applicative, forall a. a -> RidleyT t a
forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b
forall a b. RidleyT t a -> (a -> RidleyT t b) -> RidleyT t b
forall {t :: * -> *}. Monad t => Applicative (RidleyT t)
forall (t :: * -> *) a. Monad t => a -> RidleyT t a
forall (t :: * -> *) a b.
Monad t =>
RidleyT t a -> RidleyT t b -> RidleyT t b
forall (t :: * -> *) a b.
Monad t =>
RidleyT t a -> (a -> RidleyT t b) -> RidleyT t b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RidleyT t a
$creturn :: forall (t :: * -> *) a. Monad t => a -> RidleyT t a
>> :: forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b
$c>> :: forall (t :: * -> *) a b.
Monad t =>
RidleyT t a -> RidleyT t b -> RidleyT t b
>>= :: forall a b. RidleyT t a -> (a -> RidleyT t b) -> RidleyT t b
$c>>= :: forall (t :: * -> *) a b.
Monad t =>
RidleyT t a -> (a -> RidleyT t b) -> RidleyT t b
Monad, MonadReader RidleyOptions, forall a. IO a -> RidleyT t a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {t :: * -> *}. MonadIO t => Monad (RidleyT t)
forall (t :: * -> *) a. MonadIO t => IO a -> RidleyT t a
liftIO :: forall a. IO a -> RidleyT t a
$cliftIO :: forall (t :: * -> *) a. MonadIO t => IO a -> RidleyT t a
MonadIO, forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
MonadTrans)

type Ridley = RidleyT (P.RegistryT (KatipContextT IO))

data RidleyCtx = RidleyCtx {
    RidleyCtx -> ThreadId
_ridleyThreadId   :: ThreadId
  , RidleyCtx -> Maybe WaiMetrics
_ridleyWaiMetrics :: Maybe WaiMetrics
  }

makeLenses ''RidleyCtx

instance MonadThrow Ridley where
  throwM :: forall e a. Exception e => e -> Ridley a
throwM e
e = forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RidleyOptions
_ -> forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \Registry
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e

instance MonadCatch Ridley where
  catch :: forall e a. Exception e => Ridley a -> (e -> Ridley a) -> Ridley a
catch Ridley a
r e -> Ridley a
handler =
    let unwrap :: RidleyOptions -> RidleyT (RegistryT m) a -> StateT Registry m a
unwrap RidleyOptions
opts = forall (m :: * -> *) a. RegistryT m a -> StateT Registry m a
P.unRegistryT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RidleyOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. RidleyT t a -> ReaderT RidleyOptions t a
_unRidley
    in forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RidleyOptions
opts -> forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall {m :: * -> *} {a}.
RidleyOptions -> RidleyT (RegistryT m) a -> StateT Registry m a
unwrap RidleyOptions
opts Ridley a
r) (forall {m :: * -> *} {a}.
RidleyOptions -> RidleyT (RegistryT m) a -> StateT Registry m a
unwrap RidleyOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Ridley a
handler)

instance Katip Ridley where
  getLogEnv :: Ridley LogEnv
getLogEnv = forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv)
  localLogEnv :: forall a. (LogEnv -> LogEnv) -> Ridley a -> Ridley a
localLogEnv LogEnv -> LogEnv
f (Ridley (ReaderT RidleyOptions -> RegistryT (KatipContextT IO) a
m)) =
    forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT (forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv LogEnv -> LogEnv
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. RegistryT m a -> StateT Registry m a
P.unRegistryT (RidleyOptions -> RegistryT (KatipContextT IO) a
m RidleyOptions
env))

instance KatipContext Ridley where
  getKatipContext :: Ridley LogContexts
getKatipContext   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  getKatipNamespace :: Ridley Namespace
getKatipNamespace = LogEnv -> Namespace
_logEnvApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *). Katip m => m LogEnv
getLogEnv))
  localKatipContext :: forall a. (LogContexts -> LogContexts) -> Ridley a -> Ridley a
localKatipContext LogContexts -> LogContexts
f (Ridley (ReaderT RidleyOptions -> RegistryT (KatipContextT IO) a
m)) =
    forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT (forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext LogContexts -> LogContexts
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. RegistryT m a -> StateT Registry m a
P.unRegistryT (RidleyOptions -> RegistryT (KatipContextT IO) a
m RidleyOptions
env))
  localKatipNamespace :: forall a. (Namespace -> Namespace) -> Ridley a -> Ridley a
localKatipNamespace Namespace -> Namespace
f (Ridley (ReaderT RidleyOptions -> RegistryT (KatipContextT IO) a
m)) =
    forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT (forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace Namespace -> Namespace
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. RegistryT m a -> StateT Registry m a
P.unRegistryT (RidleyOptions -> RegistryT (KatipContextT IO) a
m RidleyOptions
env))

--------------------------------------------------------------------------------
runRidley :: RidleyOptions -> LogEnv -> Ridley a -> IO a
runRidley :: forall a. RidleyOptions -> LogEnv -> Ridley a -> IO a
runRidley RidleyOptions
opts LogEnv
le (Ridley ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
ridley) =
  (forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le (forall a. Monoid a => a
mempty :: SimpleLogPayload) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => RegistryT m a -> m a
P.evalRegistryT forall a b. (a -> b) -> a -> b
$ (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
ridley) RidleyOptions
opts)

-- | Returns an IO logger which uses context defined in the 'Ridley' monad. Useful when we want to use
-- an IO logger in the update functions for the handlers, which run in plain 'IO'.
ioLogger :: Ridley Logger
ioLogger :: Ridley Logger
ioLogger = do
  LogEnv
le  <- forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
  LogContexts
ctx <- forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  Namespace
ns  <- forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Severity
sev Text
txt -> forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le LogContexts
ctx Namespace
ns forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
sev (forall a. StringConv a Text => a -> LogStr
ls Text
txt)

getRidleyOptions :: Ridley RidleyOptions
getRidleyOptions :: Ridley RidleyOptions
getRidleyOptions = forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

noUpdate :: c -> Bool -> IO ()
noUpdate :: forall c. c -> Bool -> IO ()
noUpdate c
_ Bool
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()