{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-}
-- | This module contains implementation of @HasLogger@, @HasLogBackend@, @HasLogContext@ instances for IO monad.
-- This implementation uses thread-local storage, so each thread will have it's own logging state (context and logger).
--
-- This module is not automatically re-exported by System.Log.Heavy, because in many cases it is more convinient to maintain
-- logging state within monadic context, than in global variable.
--
-- Note: implementations of @HasLogger@, @HasLogBackend@, @HasLogContext@ for IO, provided by this module, work only inside
-- @withLoggingIO@ call. If you try to call logging functions outside, you will get runtime error.
--
module System.Log.Heavy.IO
  ( withLoggingIO
  ) where

import Control.Exception
import Data.IORef
import Data.TLS.GHC

import System.IO.Unsafe (unsafePerformIO)

import System.Log.Heavy.Types

-- | Logging state stored in TLS (thread-local storage)
data LoggingIOState = LoggingIOState {
    LoggingIOState -> SpecializedLogger
liosLogger :: SpecializedLogger
  , LoggingIOState -> AnyLogBackend
liosBackend :: AnyLogBackend
  , LoggingIOState -> LogContext
liosContext :: LogContext
  }

-- | This global variable stores logging state.
-- Nothing inside IORef means that logging state is not initialized yet
-- or is already deinitialized.
loggingTLS :: TLS (IORef (Maybe LoggingIOState))
loggingTLS :: TLS (IORef (Maybe LoggingIOState))
loggingTLS = IO (TLS (IORef (Maybe LoggingIOState)))
-> TLS (IORef (Maybe LoggingIOState))
forall a. IO a -> a
unsafePerformIO (IO (TLS (IORef (Maybe LoggingIOState)))
 -> TLS (IORef (Maybe LoggingIOState)))
-> IO (TLS (IORef (Maybe LoggingIOState)))
-> TLS (IORef (Maybe LoggingIOState))
forall a b. (a -> b) -> a -> b
$ IO (IORef (Maybe LoggingIOState))
-> IO (TLS (IORef (Maybe LoggingIOState)))
forall a. IO a -> IO (TLS a)
mkTLS (IO (IORef (Maybe LoggingIOState))
 -> IO (TLS (IORef (Maybe LoggingIOState))))
-> IO (IORef (Maybe LoggingIOState))
-> IO (TLS (IORef (Maybe LoggingIOState)))
forall a b. (a -> b) -> a -> b
$ do
    Maybe LoggingIOState -> IO (IORef (Maybe LoggingIOState))
forall a. a -> IO (IORef a)
newIORef Maybe LoggingIOState
forall a. Maybe a
Nothing
{-# NOINLINE loggingTLS #-}

-- | Execute IO actions with logging.
--
-- Note 1: logging methods calls in IO monad are only valid inside @withLoggingIO@.
--         If you try to call them outside of this function, you will receive runtime error.
-- 
-- Note 2: if you will for some reason call @withLoggingIO@ inside @withLoggingIO@ within one
--         thread, you will receive runtime error.
-- 
-- Note 3: You can call @withLoggingIO@ syntactically inside @withLoggingIO@, but within other
--         thread. I.e., the construct like following is valid:
--
--         @
--         withLoggingIO settings $ do
--             \$info "message" ()
--             ...
--             forkIO $ do
--                 withLoggingIO settings $ do
--                     \$info "message" ()
--                     ...
--         @
--
withLoggingIO :: LoggingSettings -- ^ Settings of arbitrary logging backend
              -> IO a            -- ^ Actions to be executed with logging
              -> IO a
withLoggingIO :: LoggingSettings -> IO a -> IO a
withLoggingIO (LoggingSettings LogBackendSettings b
settings) IO a
actions =
    IO LoggingIOState
-> (LoggingIOState -> IO ()) -> (LoggingIOState -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LogBackendSettings b -> IO LoggingIOState
forall b.
IsLogBackend b =>
LogBackendSettings b -> IO LoggingIOState
init LogBackendSettings b
settings)
            (LoggingIOState -> IO ()
forall p. p -> IO ()
cleanup)
            (\LoggingIOState
tls -> LoggingIOState -> IO a -> IO a
forall p p. p -> p -> p
withBackend LoggingIOState
tls IO a
actions)
  where
    init :: LogBackendSettings b -> IO LoggingIOState
init LogBackendSettings b
settings = do
      IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
      Maybe LoggingIOState
mbState <- IORef (Maybe LoggingIOState) -> IO (Maybe LoggingIOState)
forall a. IORef a -> IO a
readIORef IORef (Maybe LoggingIOState)
ioref
      case Maybe LoggingIOState
mbState of
        Just LoggingIOState
_ -> String -> IO LoggingIOState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Logging IO state is already initialized. withLoggingIO was called twice?"
        Maybe LoggingIOState
Nothing -> do
              b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings
              let logger :: SpecializedLogger
logger = Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
backend
              let st :: LoggingIOState
st = SpecializedLogger -> AnyLogBackend -> LogContext -> LoggingIOState
LoggingIOState SpecializedLogger
logger (b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend b
backend) []
              IORef (Maybe LoggingIOState) -> Maybe LoggingIOState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe LoggingIOState)
ioref (LoggingIOState -> Maybe LoggingIOState
forall a. a -> Maybe a
Just LoggingIOState
st)
              LoggingIOState -> IO LoggingIOState
forall (m :: * -> *) a. Monad m => a -> m a
return LoggingIOState
st

    cleanup :: p -> IO ()
cleanup p
st = do
      IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
      TLS (IORef (Maybe LoggingIOState)) -> IO ()
forall a. TLS a -> IO ()
freeAllTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
      IORef (Maybe LoggingIOState) -> Maybe LoggingIOState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe LoggingIOState)
ioref Maybe LoggingIOState
forall a. Maybe a
Nothing

    withBackend :: p -> p -> p
withBackend p
st p
actions = p
actions

-- | Get current logging state. Fail if it is not initialized yet.
getLogginngIOState :: IO LoggingIOState
getLogginngIOState :: IO LoggingIOState
getLogginngIOState = do
  IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
  Maybe LoggingIOState
mbState <- IORef (Maybe LoggingIOState) -> IO (Maybe LoggingIOState)
forall a. IORef a -> IO a
readIORef IORef (Maybe LoggingIOState)
ioref
  case Maybe LoggingIOState
mbState of
    Maybe LoggingIOState
Nothing -> String -> IO LoggingIOState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"get: Logging IO state is not initialized. See withLoggingIO."
    Just LoggingIOState
st -> LoggingIOState -> IO LoggingIOState
forall (m :: * -> *) a. Monad m => a -> m a
return LoggingIOState
st

-- | Modify logging state with pure function.
-- Fail if logging state is not initialized yet.
modifyLoggingIOState :: (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState :: (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState LoggingIOState -> LoggingIOState
fn = do
  IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
  IORef (Maybe LoggingIOState)
-> (Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Maybe LoggingIOState)
ioref ((Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ())
-> (Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe LoggingIOState
mbState ->
    case Maybe LoggingIOState
mbState of
      Maybe LoggingIOState
Nothing -> String -> Maybe LoggingIOState
forall a. HasCallStack => String -> a
error String
"modify: Logging IO state is not initialized. See withLoggingIO."
      Just LoggingIOState
st -> LoggingIOState -> Maybe LoggingIOState
forall a. a -> Maybe a
Just (LoggingIOState -> LoggingIOState
fn LoggingIOState
st)

instance HasLogBackend AnyLogBackend IO where
  getLogBackend :: IO AnyLogBackend
getLogBackend = do
    LoggingIOState
st <- IO LoggingIOState
getLogginngIOState 
    AnyLogBackend -> IO AnyLogBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyLogBackend -> IO AnyLogBackend)
-> AnyLogBackend -> IO AnyLogBackend
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> AnyLogBackend
liosBackend LoggingIOState
st

instance HasLogger IO where
  getLogger :: IO SpecializedLogger
getLogger = do
    LoggingIOState
st <- IO LoggingIOState
getLogginngIOState 
    SpecializedLogger -> IO SpecializedLogger
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecializedLogger -> IO SpecializedLogger)
-> SpecializedLogger -> IO SpecializedLogger
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> SpecializedLogger
liosLogger LoggingIOState
st

  localLogger :: SpecializedLogger -> IO a -> IO a
localLogger SpecializedLogger
logger IO a
actions = do
    SpecializedLogger
oldLogger <- IO SpecializedLogger
forall (m :: * -> *). HasLogger m => m SpecializedLogger
getLogger
    (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosLogger :: SpecializedLogger
liosLogger = SpecializedLogger
logger}
    a
result <- IO a
actions
    (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosLogger :: SpecializedLogger
liosLogger = SpecializedLogger
oldLogger}
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

instance HasLogContext IO where
  getLogContext :: IO LogContext
getLogContext = do
    LoggingIOState
st <- IO LoggingIOState
getLogginngIOState 
    LogContext -> IO LogContext
forall (m :: * -> *) a. Monad m => a -> m a
return (LogContext -> IO LogContext) -> LogContext -> IO LogContext
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> LogContext
liosContext LoggingIOState
st

  withLogContext :: LogContextFrame -> IO a -> IO a
withLogContext LogContextFrame
frame IO a
actions = do
    LogContext
oldContext <- IO LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
    (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosContext :: LogContext
liosContext = LogContextFrame
frameLogContextFrame -> LogContext -> LogContext
forall a. a -> [a] -> [a]
:LogContext
oldContext}
    a
result <- IO a
actions
    (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosContext :: LogContext
liosContext = LogContext
oldContext}
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result