made logging Environment

app/Environment.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+module Environment(Env (..), EnvM, runEnvM, myLogAction,defaultEnv) where
+
+import Prelude hiding (log)
+import Colog
+import Control.Monad.Reader (ReaderT (..), MonadReader)
+import Control.Monad.Trans
+import Control.Monad.IO.Unlift
+import qualified Control.Concurrent.MVar as M
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+newtype Env m = Env {logAction :: LogAction m Message}
+
+defaultEnv :: Env EnvM
+defaultEnv = Env myLogAction
+
+instance HasLog (Env EnvM) Message EnvM where
+  getLogAction :: Env EnvM -> LogAction EnvM Message
+  getLogAction = logAction
+  {-# INLINE getLogAction #-}
+  setLogAction ::LogAction EnvM Message -> Env EnvM -> Env EnvM
+  setLogAction lact env = env {logAction = lact}
+  {-# INLINE setLogAction #-}
+
+-- instead of hardcoding IO we could be parametric over a Monad
+-- but I don't see any use in that as we don't write a lib
+newtype EnvM a = EnvM {unEnvM :: ReaderT (Env EnvM) IO a }
+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env EnvM))
+
+instance MonadUnliftIO EnvM where
+  withRunInIO :: ((forall a .EnvM a -> IO a) -> IO b) -> EnvM b
+  withRunInIO inner = EnvM $ withRunInIO (\fromReader -> inner (fromReader . unEnvM))
+  {-# INLINE withRunInIO #-}
+
+modifyMVar :: M.MVar a -> (a -> EnvM (a,b)) -> EnvM b
+modifyMVar mvar action = withRunInIO $ \run -> M.modifyMVar mvar (run . action)
+
+-- logTest :: EnvM ()
+logTest = logError "This is an Error"
+
+runEnvM :: Env EnvM -> EnvM a -> IO a
+runEnvM env envm = runReaderT (unEnvM envm) env
+
+myLogAction :: LogAction EnvM Message
+myLogAction = LogAction $ EnvM . lift . T.putStrLn . formatMessage
+
+logTest' = runEnvM (Env myLogAction) logTest
+
+formatMessage :: Message -> T.Text
+formatMessage Msg{..} =
+  showMyServerity msgSeverity
+  <> showSourceLoc msgStack
+  <> msgText
+
+showMyServerity :: Severity -> T.Text
+showMyServerity s = case s of
+  Debug   -> "<7>Degbug  "
+  Info    -> "<6>Info    "
+  Warning -> "<4>Warning "
+  Error   -> "<3>Error   "

package.yaml

@@ -46,6 +46,9 @@ dependencies:
 - validation-selective
 - optparse-applicative
 - co-log
+- unliftio-core
+- unliftio
+- mtl
 
 when:
   - condition: flag(http)

tickLeisteServer.cabal

@@ -40,6 +40,7 @@ executable tickLeisteServer
       Backend.Http
       Backend.Https
       Config
+      Environment
       WaiApp
       WebSocketApp
       Paths_tickLeisteServer
@@ -50,13 +51,17 @@ executable tickLeisteServer
       aeson
     , base >=4.7 && <5
     , bytestring
+    , co-log
     , containers
     , http-types
+    , mtl
     , optparse-applicative
     , text
     , tickLeiste
     , tickLeiste-aeson
     , tomland
+    , unliftio
+    , unliftio-core
     , uuid
     , validation-selective
     , wai
@@ -87,14 +92,18 @@ test-suite tickLeisteServer-test
       aeson
     , base >=4.7 && <5
     , bytestring
+    , co-log
     , containers
     , http-types
+    , mtl
     , optparse-applicative
     , text
     , tickLeiste
     , tickLeiste-aeson
     , tickLeisteServer
     , tomland
+    , unliftio
+    , unliftio-core
     , uuid
     , validation-selective
     , wai