diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for extensible-effects-concurrent +## 0.7.1 + +- Improve call-stack support in log messages +- Expose `setLogMessageTimestamp` and `setLogMessageThreadId` + ## 0.7.0 - Remove the parameter from `closeLogChannelAfter` that had the optional: diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,5 +1,5 @@ name: extensible-effects-concurrent -version: 0.7.0 +version: 0.7.1 description: Please see the README on GitHub at synopsis: Message passing concurrency as extensible-effect homepage: https://github.com/sheyll/extensible-effects-concurrent#readme diff --git a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs --- a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs @@ -127,17 +127,21 @@ -- | This is the main entry point to running a message passing concurrency -- application. This function takes a 'Process' on top of the 'SchedulerIO' -- effect and a 'LogChannel' for concurrent logging. -schedule :: Eff (ConsProcess SchedulerIO) () -> LogChannel LogMessage -> IO () +schedule + :: HasCallStack + => Eff (ConsProcess SchedulerIO) () + -> LogChannel LogMessage + -> IO () schedule e logC = void $ withNewSchedulerState $ \schedulerStateVar -> do pidVar <- newEmptyTMVarIO - scheduleProcessWithShutdownAction schedulerStateVar pidVar $ do - mt <- lift myThreadId - mp <- lift (atomically (readTMVar pidVar)) - logInfo (show mp ++ " main process started in thread " ++ show mt) - e - logInfo (show mp ++ " main process returned") + scheduleProcessWithShutdownAction schedulerStateVar pidVar + $ interceptLogging (setLogMessageThreadId >=> logMsg) + $ do + logNotice "++++++++ main process started ++++++++" + e + logNotice "++++++++ main process returned ++++++++" where - withNewSchedulerState :: (SchedulerVar -> IO a) -> IO a + withNewSchedulerState :: HasCallStack => (SchedulerVar -> IO a) -> IO a withNewSchedulerState mainProcessAction = do myTId <- myThreadId Exc.bracket (newTVarIO (Scheduler myPid Map.empty Map.empty False logC)) @@ -146,7 +150,7 @@ where myPid = 1 tearDownScheduler myTId v = do - logChannelPutIO logC (debugMessage "begin scheduler tear down") + logChannelPutIO logC =<< debugMessageIO "begin scheduler tear down" sch <- (atomically (do @@ -156,16 +160,14 @@ return sch' ) ) - logChannelPutIO - logC - (debugMessage - ( "killing " - ++ let ts = (sch ^.. threadIdTable . traversed) - in if length ts > 100 - then show (length ts) ++ " threads" - else show ts - ) + logChannelPutIO logC =<< debugMessageIO + ( "killing " + ++ let ts = (sch ^.. threadIdTable . traversed) + in if length ts > 100 + then show (length ts) ++ " threads" + else show ts ) + imapM_ (killProcThread myTId) (sch ^. threadIdTable) Concurrent.yield atomically @@ -180,13 +182,13 @@ . to Map.null STM.check allThreadsDead ) - logChannelPutIO logC (infoMessage "all threads dead") + logChannelPutIO logC =<< infoMessageIO "all threads dead" killProcThread myTId _pid tid = when (myTId /= tid) (killThread tid) -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. -defaultMain :: Eff (ConsProcess SchedulerIO) () -> IO () +defaultMain :: HasCallStack => Eff (ConsProcess SchedulerIO) () -> IO () defaultMain c = runLoggingT (logChannelBracket 128 (Just (infoMessage "main process started")) @@ -197,11 +199,15 @@ -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMainWithLogChannel - :: LogChannel LogMessage -> Eff (ConsProcess SchedulerIO) () -> IO () + :: HasCallStack + => LogChannel LogMessage + -> Eff (ConsProcess SchedulerIO) () + -> IO () defaultMainWithLogChannel logC c = closeLogChannelAfter logC (schedule c logC) scheduleProcessWithShutdownAction - :: SchedulerVar + :: HasCallStack + => SchedulerVar -> STM.TMVar ProcessId -> Eff (ConsProcess SchedulerIO) () -> IO (Either Exc.SomeException ()) @@ -239,7 +245,10 @@ ) ) interceptLogging - (logMsg . over lmMessage (printf "[PID %7i] %s" (toInteger pid))) + (setLogMessageThreadId >=> logMsg . over + lmMessage + (printf "% 9s %s" (show pid)) + ) $ do logDebug "begin process" procAction diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs --- a/src/Control/Eff/Log/Message.hs +++ b/src/Control/Eff/Log/Message.hs @@ -65,6 +65,8 @@ , lmThreadId , lmMessage , setCallStack + , setLogMessageTimestamp + , setLogMessageThreadId , StructuredDataElement(..) , sdElementId , sdElementParameters @@ -85,6 +87,7 @@ import Control.Concurrent import GHC.Generics import Text.Printf +import System.FilePath.Posix import Control.Monad ( (>=>) ) -- | A message data type inspired by the RFC-5424 Syslog Protocol @@ -108,8 +111,16 @@ then [] else maybe "" (printf "[%s]" . show) ti - : msg - : maybe [] (pure . prettySrcLoc) loc + : (msg ++ replicate (max 0 (60 - length msg)) ' ') + : maybe + [] + (\sl -> pure + (printf "% 30s line %i" + (takeFileName (srcLocFile sl)) + (srcLocStartLine sl) + ) + ) + loc -- | Render a 'LogMessage' human readable. @@ -212,18 +223,14 @@ (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc instance Default LogMessage where - def = setCallStack callStack (LogMessage def def def def def def def def def def "") + def = LogMessage def def def def def def def def def def "" instance IsString LogMessage where fromString = infoMessage -- | Render a 'LogMessage' but set the timestamp and thread id fields. printLogMessage :: LogMessage -> IO () -printLogMessage = - setLogMessageTimestamp - >=> setLogMessageThreadId - >=> putStrLn - . renderLogMessage +printLogMessage = setLogMessageTimestamp >=> putStrLn . renderLogMessage -- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps') -- in 'lmTimestamp'. @@ -242,57 +249,63 @@ -- | Handle a 'Logs' effect for 'String' messages by re-logging the messages -- as 'LogMessage's with 'debugSeverity'. relogAsDebugMessages - :: Member (Logs LogMessage) e => Eff (Logs String ': e) a -> Eff e a -relogAsDebugMessages = withFrozenCallStack . handleLogsWith logDebug + :: (HasCallStack, Member (Logs LogMessage) e) + => Eff (Logs String ': e) a + -> Eff e a +relogAsDebugMessages = withFrozenCallStack (handleLogsWith logDebug) -- | Log a 'String' as 'LogMessage' with a given 'Severity'. -logWithSeverity :: Member (Logs LogMessage) e => Severity -> String -> Eff e () -logWithSeverity s = +logWithSeverity + :: (HasCallStack, Member (Logs LogMessage) e) + => Severity + -> String + -> Eff e () +logWithSeverity !s = withFrozenCallStack - . logMsg + $ logMsg . setCallStack callStack . set lmSeverity s . flip (set lmMessage) def -- | Log a 'String' as 'emergencySeverity'. -logEmergency :: Member (Logs LogMessage) e => String -> Eff e () -logEmergency = withFrozenCallStack . logWithSeverity emergencySeverity +logEmergency :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity) -- | Log a message with 'alertSeverity'. -logAlert :: Member (Logs LogMessage) e => String -> Eff e () -logAlert = withFrozenCallStack . logWithSeverity alertSeverity +logAlert :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logAlert = withFrozenCallStack (logWithSeverity alertSeverity) -- | Log a 'criticalSeverity' message. -logCritical :: Member (Logs LogMessage) e => String -> Eff e () -logCritical = withFrozenCallStack . logWithSeverity criticalSeverity +logCritical :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logCritical = withFrozenCallStack (logWithSeverity criticalSeverity) -- | Log a 'errorSeverity' message. -logError :: Member (Logs LogMessage) e => String -> Eff e () -logError = withFrozenCallStack . logWithSeverity errorSeverity +logError :: HasCallStack => Member (Logs LogMessage) e => String -> Eff e () +logError = withFrozenCallStack (logWithSeverity errorSeverity) -- | Log a 'warningSeverity' message. -logWarning :: Member (Logs LogMessage) e => String -> Eff e () -logWarning = withFrozenCallStack . logWithSeverity warningSeverity +logWarning :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logWarning = withFrozenCallStack (logWithSeverity warningSeverity) -- | Log a 'noticeSeverity' message. -logNotice :: Member (Logs LogMessage) e => String -> Eff e () -logNotice = withFrozenCallStack . logWithSeverity noticeSeverity +logNotice :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logNotice = withFrozenCallStack (logWithSeverity noticeSeverity) -- | Log a 'informationalSeverity' message. -logInfo :: Member (Logs LogMessage) e => String -> Eff e () -logInfo = withFrozenCallStack . logWithSeverity informationalSeverity +logInfo :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logInfo = withFrozenCallStack (logWithSeverity informationalSeverity) -- | Log a 'debugSeverity' message. -logDebug :: Member (Logs LogMessage) e => String -> Eff e () -logDebug = withFrozenCallStack . logWithSeverity debugSeverity +logDebug :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e () +logDebug = withFrozenCallStack (logWithSeverity debugSeverity) -- | Construct a 'LogMessage' with 'errorSeverity' -errorMessage :: String -> LogMessage +errorMessage :: HasCallStack => String -> LogMessage errorMessage m = withFrozenCallStack (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack) -- | Construct a 'LogMessage' with 'informationalSeverity' -infoMessage :: String -> LogMessage +infoMessage :: HasCallStack => String -> LogMessage infoMessage m = withFrozenCallStack ( def & lmSeverity @@ -303,23 +316,30 @@ ) -- | Construct a 'LogMessage' with 'debugSeverity' -debugMessage :: String -> LogMessage +debugMessage :: HasCallStack => String -> LogMessage debugMessage m = withFrozenCallStack (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack) -- | Construct a 'LogMessage' with 'errorSeverity' -errorMessageIO :: MonadIO m => String -> m LogMessage +errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage errorMessageIO = - (setLogMessageThreadId >=> setLogMessageTimestamp) . errorMessage + withFrozenCallStack + $ (setLogMessageThreadId >=> setLogMessageTimestamp) + . errorMessage + -- | Construct a 'LogMessage' with 'informationalSeverity' -infoMessageIO :: MonadIO m => String -> m LogMessage +infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage infoMessageIO = - (setLogMessageThreadId >=> setLogMessageTimestamp) . infoMessage + withFrozenCallStack + $ (setLogMessageThreadId >=> setLogMessageTimestamp) + . infoMessage + -- | Construct a 'LogMessage' with 'debugSeverity' -debugMessageIO :: MonadIO m => String -> m LogMessage +debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage debugMessageIO = - (setLogMessageThreadId >=> setLogMessageTimestamp) . debugMessage - + withFrozenCallStack + $ (setLogMessageThreadId >=> setLogMessageTimestamp) + . debugMessage emergencySeverity :: Severity emergencySeverity = Severity 0