{-# 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
  , openFDWarningTreshold
  , 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 = (HasCallStack => RidleyMetricHandler) -> RidleyMetricHandler
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => RidleyMetricHandler) -> RidleyMetricHandler)
-> (HasCallStack => RidleyMetricHandler) -> RidleyMetricHandler
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 CallStack
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.
                                 (Ridley 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
_ Ridley RidleyMetricHandler
_) = String
"Custom@" String -> ShowS
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
_ Ridley RidleyMetricHandler
_) (CustomMetric Text
n2 Maybe Int
_ Ridley RidleyMetricHandler
_) = Text -> Text -> Bool
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
_ Ridley 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
_ Ridley RidleyMetricHandler
_)    -> Text -> Text -> Ordering
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
  , RidleyOptions -> Int
_openFDWarningTreshold :: !Int
  -- ^ How much to retain the data, in seconds.
  -- Pass `Nothing` to not flush the metrics.
  }

--------------------------------------------------------------------------------
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     = [RidleyMetric] -> Set RidleyMetric
forall a. Ord a => [a] -> Set a
Set.fromList [RidleyMetric]
metrics
  , _katipSeverity :: Severity
_katipSeverity     = Severity
InfoS
  , _katipScribes :: (Namespace, [(Text, Scribe)])
_katipScribes      = (Namespace, [(Text, Scribe)])
forall a. Monoid a => a
mempty
  , _dataRetentionPeriod :: Maybe NominalDiffTime
_dataRetentionPeriod = Maybe NominalDiffTime
forall a. Maybe a
Nothing
  , _openFDWarningTreshold :: Int
_openFDWarningTreshold = Int
100
  }

--------------------------------------------------------------------------------
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 -> b) -> RidleyT t a -> RidleyT t b)
-> (forall a b. a -> RidleyT t b -> RidleyT t a)
-> Functor (RidleyT t)
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
$cfmap :: forall (t :: * -> *) a b.
Functor t =>
(a -> b) -> RidleyT t a -> RidleyT t b
fmap :: forall a b. (a -> b) -> RidleyT t a -> RidleyT t b
$c<$ :: forall (t :: * -> *) a b.
Functor t =>
a -> RidleyT t b -> RidleyT t a
<$ :: forall a b. a -> RidleyT t b -> RidleyT t a
Functor, Functor (RidleyT t)
Functor (RidleyT t) =>
(forall a. a -> RidleyT t a)
-> (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 a b. RidleyT t a -> RidleyT t b -> RidleyT t b)
-> (forall a b. RidleyT t a -> RidleyT t b -> RidleyT t a)
-> Applicative (RidleyT t)
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
$cpure :: forall (t :: * -> *) a. Applicative t => a -> RidleyT t a
pure :: forall a. a -> RidleyT t a
$c<*> :: forall (t :: * -> *) a b.
Applicative t =>
RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
<*> :: forall a b. RidleyT t (a -> b) -> RidleyT t a -> RidleyT t b
$cliftA2 :: forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
liftA2 :: forall a b c.
(a -> b -> c) -> RidleyT t a -> RidleyT t b -> RidleyT t c
$c*> :: forall (t :: * -> *) a b.
Applicative t =>
RidleyT t a -> RidleyT t b -> RidleyT t b
*> :: 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 a
<* :: forall a b. RidleyT t a -> RidleyT t b -> RidleyT t a
Applicative, Applicative (RidleyT t)
Applicative (RidleyT t) =>
(forall a b. RidleyT t a -> (a -> RidleyT t b) -> RidleyT t b)
-> (forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b)
-> (forall a. a -> RidleyT t a)
-> Monad (RidleyT t)
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
$c>>= :: forall (t :: * -> *) a b.
Monad t =>
RidleyT t a -> (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 -> RidleyT t b -> RidleyT t b
>> :: forall a b. RidleyT t a -> RidleyT t b -> RidleyT t b
$creturn :: forall (t :: * -> *) a. Monad t => a -> RidleyT t a
return :: forall a. a -> RidleyT t a
Monad, MonadReader RidleyOptions, Monad (RidleyT t)
Monad (RidleyT t) =>
(forall a. IO a -> RidleyT t a) -> MonadIO (RidleyT t)
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
$cliftIO :: forall (t :: * -> *) a. MonadIO t => IO a -> RidleyT t a
liftIO :: forall a. IO a -> RidleyT t a
MonadIO, (forall (t :: * -> *). Monad t => Monad (RidleyT t)) =>
(forall (m :: * -> *) a. Monad m => m a -> RidleyT m a)
-> MonadTrans RidleyT
forall (t :: * -> *). Monad t => Monad (RidleyT t)
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
lift :: 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
  }

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

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

instance Katip Ridley where
  getLogEnv :: Ridley LogEnv
getLogEnv = ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
-> Ridley LogEnv
forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
 -> Ridley LogEnv)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
-> Ridley LogEnv
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) LogEnv
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
forall (m :: * -> *) a. Monad m => m a -> ReaderT RidleyOptions m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (KatipContextT IO LogEnv -> RegistryT (KatipContextT IO) LogEnv
forall (m :: * -> *) a. Monad m => m a -> RegistryT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift KatipContextT IO LogEnv
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)) =
    ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
 -> RidleyT (RegistryT (KatipContextT IO)) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((RidleyOptions -> RegistryT (KatipContextT IO) a)
 -> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a)
-> (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> StateT Registry (KatipContextT IO) a
-> RegistryT (KatipContextT IO) a
forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT ((LogEnv -> LogEnv)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a.
(LogEnv -> LogEnv)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv LogEnv -> LogEnv
f (StateT Registry (KatipContextT IO) a
 -> StateT Registry (KatipContextT IO) a)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
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   = LogContexts -> Ridley LogContexts
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return LogContexts
forall a. Monoid a => a
mempty
  getKatipNamespace :: Ridley Namespace
getKatipNamespace = LogEnv -> Namespace
_logEnvApp (LogEnv -> Namespace) -> Ridley LogEnv -> Ridley Namespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
-> Ridley LogEnv
forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (RegistryT (KatipContextT IO) LogEnv
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
forall (m :: * -> *) a. Monad m => m a -> ReaderT RidleyOptions m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) LogEnv
 -> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv)
-> RegistryT (KatipContextT IO) LogEnv
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) LogEnv
forall a b. (a -> b) -> a -> b
$ KatipContextT IO LogEnv -> RegistryT (KatipContextT IO) LogEnv
forall (m :: * -> *) a. Monad m => m a -> RegistryT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (KatipContextT IO LogEnv
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)) =
    ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
 -> RidleyT (RegistryT (KatipContextT IO)) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((RidleyOptions -> RegistryT (KatipContextT IO) a)
 -> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a)
-> (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> StateT Registry (KatipContextT IO) a
-> RegistryT (KatipContextT IO) a
forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT ((LogContexts -> LogContexts)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a.
(LogContexts -> LogContexts)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext LogContexts -> LogContexts
f (StateT Registry (KatipContextT IO) a
 -> StateT Registry (KatipContextT IO) a)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
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)) =
    ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall (t :: * -> *) a. ReaderT RidleyOptions t a -> RidleyT t a
Ridley (ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
 -> RidleyT (RegistryT (KatipContextT IO)) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyT (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((RidleyOptions -> RegistryT (KatipContextT IO) a)
 -> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a)
-> (RidleyOptions -> RegistryT (KatipContextT IO) a)
-> ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
forall a b. (a -> b) -> a -> b
$ \RidleyOptions
env -> StateT Registry (KatipContextT IO) a
-> RegistryT (KatipContextT IO) a
forall (m :: * -> *) a. StateT Registry m a -> RegistryT m a
P.RegistryT ((Namespace -> Namespace)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a.
(Namespace -> Namespace)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace Namespace -> Namespace
f (StateT Registry (KatipContextT IO) a
 -> StateT Registry (KatipContextT IO) a)
-> StateT Registry (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) a
-> StateT Registry (KatipContextT IO) a
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) =
  (LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO a -> IO a
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le (SimpleLogPayload
forall a. Monoid a => a
mempty :: SimpleLogPayload) Namespace
forall a. Monoid a => a
mempty (KatipContextT IO a -> IO a) -> KatipContextT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) a -> KatipContextT IO a
forall (m :: * -> *) a. Monad m => RegistryT m a -> m a
P.evalRegistryT (RegistryT (KatipContextT IO) a -> KatipContextT IO a)
-> RegistryT (KatipContextT IO) a -> KatipContextT IO a
forall a b. (a -> b) -> a -> b
$ (ReaderT RidleyOptions (RegistryT (KatipContextT IO)) a
-> RidleyOptions -> RegistryT (KatipContextT IO) a
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  <- Ridley LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
  LogContexts
ctx <- Ridley LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  Namespace
ns  <- Ridley Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  Logger -> Ridley Logger
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Logger -> Ridley Logger) -> Logger -> Ridley Logger
forall a b. (a -> b) -> a -> b
$ \Severity
sev Text
txt -> LogEnv -> LogContexts -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le LogContexts
ctx Namespace
ns (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
sev (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
txt)

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

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

makeLenses ''RidleyCtx
makeLenses ''RidleyOptions