89 lines
2.6 KiB
Haskell
89 lines
2.6 KiB
Haskell
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
|
|
module M where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (bracket)
|
|
import Control.Lens (over, view)
|
|
import Control.Lens.TH (makeFields)
|
|
import Control.Monad.Base (MonadBase)
|
|
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
|
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, local, runReaderT)
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
import Creds
|
|
import GHC.Generics (Generic)
|
|
import HTTP (HTTPMetric (HTTPMetric))
|
|
import Katip qualified as K
|
|
import System.IO (stdout)
|
|
import System.Metrics qualified as EKG
|
|
import UnliftIO (MonadUnliftIO)
|
|
import Wallabag.Auth (Auth, Auth' (..))
|
|
import qualified Data.HashMap.Strict as HM
|
|
|
|
data S = S
|
|
{ _sTokenCache :: Auth,
|
|
_sLogNamespace :: K.Namespace,
|
|
_sLogEnv :: K.LogEnv,
|
|
_sLogContext :: K.LogContexts,
|
|
_sCreds :: Creds,
|
|
_sWallabagMetrics :: HTTPMetric,
|
|
_sOpenrouterMetrics :: HTTPMetric
|
|
}
|
|
deriving (Generic)
|
|
|
|
makeFields ''S
|
|
|
|
newtype M a = M (ReaderT S IO a)
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadReader S,
|
|
MonadIO,
|
|
MonadUnliftIO,
|
|
MonadThrow,
|
|
MonadCatch,
|
|
MonadBaseControl IO,
|
|
MonadBase IO
|
|
)
|
|
|
|
runM :: S -> M a -> IO a
|
|
runM s (M m) = runReaderT m s
|
|
|
|
instance K.Katip M where
|
|
getLogEnv = view logEnv
|
|
localLogEnv = local . over logEnv
|
|
|
|
instance K.KatipContext M where
|
|
getKatipContext = view logContext
|
|
localKatipContext = local . over logContext
|
|
getKatipNamespace = view logNamespace
|
|
localKatipNamespace = local . over logNamespace
|
|
|
|
initialS :: K.Severity -> (S -> IO a) -> IO a
|
|
initialS severity f = do
|
|
store <- EKG.newStore
|
|
wbMetrics <-
|
|
HTTPMetric
|
|
<$> EKG.createDistribution "wallabag.requests" store
|
|
<*> EKG.createCounter "wallabag.retries" store
|
|
<*> EKG.createCounter "wallabag.failures" store
|
|
orMetrics <-
|
|
HTTPMetric
|
|
<$> EKG.createDistribution "openrouter.requests" store
|
|
<*> EKG.createCounter "openrouter.retries" store
|
|
<*> EKG.createCounter "openrouter.failures" store
|
|
c <- getCreds
|
|
handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem severity) K.V2
|
|
let makeLogEnv = K.registerScribe "stdout" handleScribe K.defaultScribeSettings =<< K.initLogEnv "wallabag" "production"
|
|
res <- bracket makeLogEnv K.closeScribes $ \le -> do
|
|
cache <- newTVarIO Unauthenticated
|
|
f (S cache "main" le mempty c wbMetrics orMetrics)
|
|
-- TODO: This is just for debug purposes
|
|
EKG.sampleAll store >>= mapM_ print . HM.toList
|
|
pure res
|