LogContext.hs

{-# LANGUAGE FlexibleInstances #-}
module LogContext (testLogContext) where

import Control.Concurrent
-- import Control.Concurrent.Async


--------------------------------------------------------------------------------
-- Abstract logger language
--------------------------------------------------------------------------------

type Context = [(String, String)]

class Monad m => Contextual m where
    withContext :: Context -> m a -> m a
    getContext :: m Context

class Monad m => ILogger m where
    logInfo :: String -> m ()

class Monad m => MonadIO m where
    liftIO :: IO a -> m a

instance MonadIO IO where
    liftIO = id


--------------------------------------------------------------------------------
-- A concrete logger
--------------------------------------------------------------------------------

data Logger m a = Logger { runLogger :: Context -> m (a, Context) }

withLogs :: Functor m => Context -> Logger m a -> m a
withLogs ctx m = fst <$> runLogger m ctx

lift :: Functor f => f a -> Logger f a
lift m = Logger $ \ctx -> fmap (\a -> (a, ctx)) m

instance Monad m => Functor (Logger m) where
    fmap f (Logger la) =
        Logger $ \ctx -> do
            (a, ctx') <- la ctx
            pure (f a, ctx')

instance Monad m => Applicative (Logger m) where
    pure a = Logger $ \ctx -> pure (a, ctx)
    Logger pf <*> Logger pa =
        Logger $ \ctx -> do
            (f, ctx') <- pf ctx
            (a, ctx'') <- pa ctx'
            pure (f a, ctx'')

instance Monad m => Monad (Logger m) where
    Logger pa >>= f =
        Logger $ \ctx -> do
            (a, ctx') <- pa ctx
            runLogger (f a) ctx'

instance MonadIO m => MonadIO (Logger m) where
    liftIO io = Logger $ \ctx -> do
      a <- liftIO io
      pure (a, ctx)

instance Monad m => Contextual (Logger m) where
    withContext moreCtx m =
        Logger $ \ctx -> do
          a <- withLogs (moreCtx ++ ctx) m
          pure (a, ctx)
    getContext = Logger $ \ctx -> pure (ctx, ctx)

instance MonadIO m => ILogger (Logger m) where
    logInfo s = do
        ctx <- getContext
        liftIO $ putStrLn (show ctx ++ ": " ++ s)


--------------------------------------------------------------------------------
-- Test code (mono-threaded)
--------------------------------------------------------------------------------

type TradeId = Int

domainLogic :: (Contextual m, ILogger m) => TradeId -> m ()
domainLogic tradeId = do
    logInfo "Start batch"
    withContext [("Loading trade", show tradeId)] $ do
        logInfo "INFO - Looking good"
        logInfo "ERROR - Missing counterpart"
    logInfo "End of batch"


--------------------------------------------------------------------------------
-- Asynchronous logs with automatic context transfers
--------------------------------------------------------------------------------

class Monad m => IAsync m where
    async :: m a -> m (MVar a)
    await :: MVar a -> m a

instance IAsync IO where
    async io = do
        mvar <- newEmptyMVar
        forkIO (io >>= putMVar mvar)
        pure mvar
    await a = takeMVar a

instance IAsync m => IAsync (Logger m) where
  async logger = Logger $ \ctx -> do
      a <- async (withLogs ctx logger)
      pure (a, ctx)
  await v = Logger $ \ctx -> do
      a <- await v
      pure (a, ctx)


--------------------------------------------------------------------------------
-- Test code (running several threads)
--------------------------------------------------------------------------------

multiAgent :: (ILogger m, Contextual m, IAsync m, MonadIO m) => m ()
multiAgent = do
    logInfo "Before context"
    payload <- withContext [("REST", "Client")] $ do
        logInfo "Before asynchronous call"
        async $ do
          payload <- httpGet "http://www.google.fr"
          logInfo "Received payload"
          return payload
    logInfo "After context"
    await payload
    pure ()

type URL = String
type Payload = String

httpGet :: (ILogger m, Contextual m, MonadIO m) => URL -> m Payload
httpGet url = do
    liftIO (threadDelay 100000)
    pure "payload"


--------------------------------------------------------------------------------
-- Main
--------------------------------------------------------------------------------

testLogContext :: IO ()
testLogContext = do
    let separator = putStrLn (replicate 40 '-')
    withLogs [] (domainLogic 1)
    separator
    withLogs [] multiAgent