@@ -31,6 +31,9 @@ import qualified Control.Concurrent.STM.TBQueue as BQ
3131import Control.Exception.Safe
3232import Control.Monad (unless, void, when)
3333import Control.Monad.Base
34+#if MIN_VERSION_base(4, 9, 0)
35+import qualified Control.Monad.Fail as MF
36+#endif
3437import Control.Monad.IO.Class
3538import Control.Monad.IO.Unlift
3639import Control.Monad.Trans.Class
@@ -41,7 +44,8 @@ import Control.Monad.Trans.Either
4144import Control.Monad.Trans.Except
4245import Control.Monad.Trans.Maybe
4346import Control.Monad.Trans.Reader
44−import Control.Monad.Trans.Resource (ResourceT, transResourceT)
47+import Control.Monad.Trans.Resource (MonadResource, ResourceT,
48+ transResourceT)
4549import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST)
4650import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
4751import Control.Monad.Trans.State.Lazy (StateT, mapStateT)
@@ -661,7 +665,7 @@ makeLenses ''LogEnv
661665
662666
663667-------------------------------------------------------------------------------
664−-- | Create a reasonable default InitLogEnv. Uses an 'AutoUdate' which
668+-- | Create a reasonable default InitLogEnv. Uses an 'AutoUpdate' which
665669-- updates the timer every 1ms. If you need even more timestamp
666670-- precision at the cost of performance, consider setting
667671-- '_logEnvTimer' with 'getCurrentTime'.
@@ -876,7 +880,8 @@ instance (Katip m) => Katip (ResourceT m) where
876880-- opposed to implementing 'Katip' for your monad.
877881newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
878882 deriving ( Functor, Applicative, Monad, MonadIO
879− , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)
883+ , MonadMask, MonadCatch, MonadThrow, MonadResource, MonadTrans
884+ , MonadBase b)
880885
881886
882887instance MonadIO m => Katip (KatipT m) where
@@ -898,9 +903,20 @@ instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where
898903 restoreM = defaultRestoreM
899904
900905instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where
906+#if MIN_VERSION_unliftio_core(0, 2, 0)
907+ withRunInIO inner = KatipT $ ReaderT $ \le -> withRunInIO $ \run ->
908+ inner (run . runKatipT le)
909+#else
901910 askUnliftIO = KatipT $
902− withUnliftIO $ \u ->
903− pure (UnliftIO (unliftIO u . unKatipT))
911+ withUnliftIO $ \u ->
912+ pure (UnliftIO (unliftIO u . unKatipT))
913+#endif
914+
915+#if MIN_VERSION_base(4, 9, 0)
916+instance MF.MonadFail m => MF.MonadFail (KatipT m) where
917+ fail msg = lift (MF.fail msg)
918+ {-# INLINE fail #-}
919+#endif
904920
905921-------------------------------------------------------------------------------
906922-- | Execute 'KatipT' on a log env.
@@ -932,19 +948,29 @@ logItem
932948 -> m ()
933949logItem a ns loc sev msg = do
934950 LogEnv{..} <- getLogEnv
935− liftIO $ do
936− item <- Item
937− <$> pure _logEnvApp
938− <*> pure _logEnvEnv
939− <*> pure sev
940− <*> (mkThreadIdText <$> myThreadId)
941− <*> pure _logEnvHost
942− <*> pure _logEnvPid
943− <*> pure a
944− <*> pure msg
945− <*> _logEnvTimer
946− <*> pure (_logEnvApp <> ns)
947− <*> pure loc
951+ logKatipItem =<< liftIO
952+ (Item <$> pure _logEnvApp
953+ <*> pure _logEnvEnv
954+ <*> pure sev
955+ <*> (mkThreadIdText <$> myThreadId)
956+ <*> pure _logEnvHost
957+ <*> pure _logEnvPid
958+ <*> pure a
959+ <*> pure msg
960+ <*> _logEnvTimer
961+ <*> pure (_logEnvApp <> ns)
962+ <*> pure loc)
963+
964+-- | Log already constructed 'Item'. This is the lowest level function that other log*
965+-- functions use.
966+-- It can be useful when implementing centralised logging services.
967+logKatipItem
968+ :: (A.Applicative m, LogItem a, Katip m)
969+ => Item a
970+ -> m ()
971+logKatipItem item = do
972+ LogEnv{..} <- getLogEnv
973+ liftIO $
948974 FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> do
949975 whenM (scribePermitItem shScribe item) $
950976 void $ atomically (tryWriteTBQueue shChan (NewItem item))
@@ -993,7 +1019,7 @@ logException
9931019logException a ns sev action = action `catchAny` \e -> f e >> throwM e
9941020 where
9951021 f e = logF a ns sev (msg e)
996− msg e = ls (T.pack "An exception has occured: ") <> showLS e
1022+ msg e = ls (T.pack "An exception has occurred: ") <> showLS e
9971023
9981024
9991025-------------------------------------------------------------------------------