Add thread to logs

tbidne · May 12, 2024 · 9b5b474 · 9b5b474
1 parent 114b7b9
commit 9b5b474
Show file tree

Hide file tree

Showing 4 changed files with 10 additions and 6 deletions.
diff --git a/cabal.project b/cabal.project
@@ -34,7 +34,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/tbidne/monad-effects.git
-    tag: 1725ed9812a21c7d3d32f5becc01a2eaab76cc9f
+    tag: c02f58fcd475e447b69094456a186fd613dea930
     subdir:
         lib/effects-env
         lib/effects-exceptions

diff --git a/flake.lock b/flake.lock
diff --git a/src/Navi.hs b/src/Navi.hs
@@ -16,7 +16,7 @@ import DBus.Notify (UrgencyLevel (Critical, Normal))
 import Data.Text qualified as T
 import Effects.Concurrent.Async qualified as Async
 import Effects.Concurrent.STM (flushTBQueueA)
-import Effects.Concurrent.Thread (sleep)
+import Effects.Concurrent.Thread (MonadThread (labelThread, myThreadId), sleep)
 import Effects.LoggerNS
   ( MonadLoggerNS,
     addNamespace,
@@ -142,6 +142,8 @@ processEvent ::
   AnyEvent ->
   m Void
 processEvent (MkAnyEvent event) = addNamespace (fromString $ unpack name) $ do
+  tid <- myThreadId
+  labelThread tid (fromString $ unpack name)
   let pi = event ^. (#pollInterval % #unPollInterval)
   forever $ do
     $(logInfo) ("Checking " <> name)

diff --git a/src/Navi/NaviT.hs b/src/Navi/NaviT.hs
@@ -112,8 +112,10 @@ instance
     logQueue <- asks getLogQueue
     logLevel <- asks (view #logLevel . getLogEnv)
     when (logLevel <= lvl) $ do
-      formatted <- formatLog (defaultLogFormatter loc) lvl msg
+      formatted <- formatLog formatter lvl msg
       writeTBQueueA logQueue formatted
+    where
+      formatter = set' #threadLabel True (defaultLogFormatter loc)
 
 instance
   ( HasLogEnv env,