Initial commit

src/M.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module M where
+
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Control.Lens (over, view)
+import Control.Lens.TH (makeFields)
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, local, runReaderT)
+import Creds
+import GHC.Generics (Generic)
+import Katip qualified as K
+import System.IO (stdout)
+import UnliftIO (MonadUnliftIO)
+import Wallabag (Auth, Auth' (..))
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Base (MonadBase)
+
+data S = S
+  { _sTokenCache :: Auth,
+    _sLogNamespace :: K.Namespace,
+    _sLogEnv :: K.LogEnv,
+    _sLogContext :: K.LogContexts,
+    _sCreds :: Creds
+  }
+  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
+  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"
+  bracket makeLogEnv K.closeScribes $ \le -> do
+    cache <- newTVarIO Unauthenticated
+    f (S cache "main" le mempty c)