extensible-effects-concurrent 0.20.0 → 0.21.0

raw patch · 34 files changed

+2635/−1171 lines, 34 filesdep +bytestringdep +socketdep +socket-unixdep ~filepathdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, socket, socket-unix, text

Dependency ranges changed: filepath, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−0
• examples/example-1/Main.hs +13/−12
• examples/example-2/Main.hs +2/−2
• examples/example-3/Main.hs +6/−3
• examples/example-4/Main.hs +3/−3
• extensible-effects-concurrent.cabal +32/−3
• src/Control/Eff/Concurrent.hs +33/−0
• src/Control/Eff/Concurrent/Api/Observer/Queue.hs +5/−4
• src/Control/Eff/Concurrent/Api/Server.hs +9/−8
• src/Control/Eff/Concurrent/Process.hs +38/−34
• src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +556/−438
• src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +3/−1
• src/Control/Eff/Log.hs +61/−152
• src/Control/Eff/Log/Channel.hs +0/−88
• src/Control/Eff/Log/Examples.hs +240/−0
• src/Control/Eff/Log/Handler.hs +129/−110
• src/Control/Eff/Log/Message.hs +104/−163
• src/Control/Eff/Log/MessageRenderer.hs +224/−0
• src/Control/Eff/Log/Writer.hs +4/−98
• src/Control/Eff/LogWriter/Async.hs +119/−0
• src/Control/Eff/LogWriter/Capture.hs +46/−0
• src/Control/Eff/LogWriter/Console.hs +64/−0
• src/Control/Eff/LogWriter/DebugTrace.hs +55/−0
• src/Control/Eff/LogWriter/File.hs +79/−0
• src/Control/Eff/LogWriter/IO.hs +89/−0
• src/Control/Eff/LogWriter/UDP.hs +87/−0
• src/Control/Eff/LogWriter/UnixSocket.hs +79/−0
• stack.yaml +3/−0
• test/ForkIOScheduler.hs +8/−8
• test/LogMessageIdeaTest.hs +482/−0
• test/LoggingTests.hs +5/−6
• test/LoopTests.hs +4/−3
• test/ProcessBehaviourTestCases.hs +37/−34
• test/SingleThreadedScheduler.hs +1/−1

@@ -1,5 +1,20 @@ # Changelog for extensible-effects-concurrent +## 0.21.0++- Add more log message renderers++    - Multiple extra time stamp formats+    - RFC3164++- Add IO log writer for unix domain sockets, e.g. `/dev/log`++- Add IO log writer for UDP++- Extract and simplify the async logger++- Extract and simplify the file log writers+ ## 0.20.0  - Rewrite Logging API so that usage is not as bloated

@@ -7,6 +7,7 @@ import           Data.Dynamic import           Control.Eff.Concurrent import qualified Control.Exception             as Exc+import qualified Data.Text as T  data TestApi   deriving Typeable@@ -34,9 +35,9 @@ example:: ( HasCallStack, Member Logs q, Lifted IO q) => Eff (InterruptableProcess q) () example = do   me <- self-  logInfo ("I am " ++ show me)+  logInfo (T.pack ("I am " ++ show me))   server <- testServerLoop-  logInfo ("Started server " ++ show server)+  logInfo (T.pack ("Started server " ++ show server))   let go = do         lift (putStr "Enter something: ")         x <- lift getLine@@ -56,7 +57,7 @@           ('q' : _) -> logInfo "Done."           _         -> do             res <- callRegistered (SayHello x)-            logInfo ("Result: " ++ show res)+            logInfo (T.pack ("Result: " ++ show res))             go   registerServer server go @@ -72,41 +73,41 @@  where   handleCastTest = handleCasts $ \(Shout x) -> do     me <- self-    logInfo (show me ++ " Shouting: " ++ x)+    logInfo (T.pack (show me ++ " Shouting: " ++ x))     return AwaitNext   handleCallTest :: Api TestApi ('Synchronous r) -> (Eff (InterruptableProcess q) (Maybe r, CallbackResult) -> xxx) -> xxx   handleCallTest (SayHello "e1") k = k $ do     me <- self-    logInfo (show me ++ " raising an error")+    logInfo (T.pack (show me ++ " raising an error"))     interrupt (ProcessError "No body loves me... :,(")   handleCallTest (SayHello "e2") k = k $ do     me <- self-    logInfo (show me ++ " throwing a MyException ")+    logInfo (T.pack (show me ++ " throwing a MyException "))     void (lift (Exc.throw MyException))     pure (Nothing, AwaitNext)   handleCallTest (SayHello "self") k = k $ do     me <- self-    logInfo (show me ++ " casting to self")+    logInfo (T.pack (show me ++ " casting to self"))     cast (asServer @TestApi me) (Shout "from me")     return (Just False, AwaitNext)   handleCallTest (SayHello "stop") k = k $ do     me <- self-    logInfo (show me ++ " stopping me")+    logInfo (T.pack (show me ++ " stopping me"))     return (Just False, StopServer (ProcessError "test error"))   handleCallTest (SayHello x) k = k $ do     me <- self-    logInfo (show me ++ " Got Hello: " ++ x)+    logInfo (T.pack (show me ++ " Got Hello: " ++ x))     return (Just (length x > 3), AwaitNext)   handleCallTest Terminate k = k $ do     me <- self-    logInfo (show me ++ " exiting")+    logInfo (T.pack (show me ++ " exiting"))     pure (Just (), StopServer ProcessFinished)   handleCallTest (TerminateError msg) k = k $ do     me <- self-    logInfo (show me ++ " exiting with error: " ++ msg)+    logInfo (T.pack (show me ++ " exiting with error: " ++ msg))     pure (Just (), StopServer (ProcessError msg))   handleTerminateTest = InterruptCallback $ \msg -> do     me <- self-    logInfo (show me ++ " is exiting: " ++ show msg)+    logInfo (T.pack (show me ++ " is exiting: " ++ show msg))     logProcessExit msg     pure (StopServer msg)

@@ -33,7 +33,7 @@   lift (threadDelay 500000)   cast c Inc   lift (threadDelay 500000)-  sendMessage cp "test 123"+  sendMessage cp ("test 123" :: String)   cast c Inc   lift (threadDelay 500000)   cast c Inc@@ -132,7 +132,7 @@   svr <- spawnApiServer     (handleObservations       (\msg -> do-        logInfo ("observed: " ++ show msg)+        logInfo' ("observed: " ++ show msg)         return AwaitNext       )     )

@@ -2,16 +2,19 @@  import           Control.Eff import           Control.Eff.Log+import           Control.Eff.LogWriter.File+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.DebugTrace import           Control.Lens  main :: IO () main =   runLift   $  withSomeLogging @IO-  $  withLogFileAppender  "extensible-effects-concurrent-example-3.log"-  $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced: "++)) debugTraceLogWriter))+  $  withFileLogWriter  "extensible-effects-concurrent-example-3.log"+  $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced: " <>)) (debugTraceLogWriter renderRFC5424)))   $  modifyLogWriter (defaultIoLogWriter "example-3" local0)-  $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced without timestamp: "++)) debugTraceLogWriter))+  $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced without timestamp: " <>)) (debugTraceLogWriter renderRFC5424)))   $  do         logEmergency "test emergencySeverity 1"         logCritical "test criticalSeverity 2"

@@ -20,10 +20,10 @@     (do       logInfo "I am waiting for someone to ask me..."       WhoAreYou replyPid <- receiveMessage-      sendMessage replyPid "Alice"-      logInfo (show replyPid ++ " just needed to know it.")+      sendMessage replyPid ("Alice" :: String)+      logInfo' (show replyPid ++ " just needed to know it.")     )   me <- self   sendMessage person (WhoAreYou me)   personName <- receiveMessage-  logInfo ("I just met " ++ personName)+  logInfo' ("I just met " ++ personName)

@@ -1,6 +1,6 @@ cabal-version:  2.0 name:           extensible-effects-concurrent-version:        0.20.0+version:        0.21.0 description:    Please see the README on GitHub at <https://github.com/sheyll/extensible-effects-concurrent#readme> synopsis:       Message passing concurrency as extensible-effect homepage:       https://github.com/sheyll/extensible-effects-concurrent#readme@@ -40,6 +40,7 @@   build-depends:       async >= 2.2 && <3,       base >= 4.12 && <5,+      bytestring >= 0.10 && < 0.11,       data-default >= 0.7 && < 0.8,       deepseq >= 1.4 && < 1.5,       directory,@@ -57,16 +58,28 @@       monad-control >= 1.0 && < 1.1,       extensible-effects >= 5 && < 6,       stm >= 2.4.5 && <2.6,-      transformers-base >= 0.4 && < 0.5+      transformers-base >= 0.4 && < 0.5,+      socket >= 0.8 && < 0.9,+      socket-unix >= 0.2 && < 0.3,+      text >= 1.2 && < 1.3   autogen-modules: Paths_extensible_effects_concurrent   exposed-modules:                   Control.Eff.Loop,                   Control.Eff.ExceptionExtra,                   Control.Eff.Log,-                  Control.Eff.Log.Channel,+                  Control.Eff.Log.Examples,                   Control.Eff.Log.Handler,                   Control.Eff.Log.Message,+                  Control.Eff.Log.MessageRenderer,                   Control.Eff.Log.Writer,+                  Control.Eff.LogWriter.Async,+                  Control.Eff.LogWriter.Console,+                  Control.Eff.LogWriter.Capture,+                  Control.Eff.LogWriter.DebugTrace,+                  Control.Eff.LogWriter.File,+                  Control.Eff.LogWriter.IO,+                  Control.Eff.LogWriter.UDP,+                  Control.Eff.LogWriter.UnixSocket,                   Control.Eff.Concurrent,                   Control.Eff.Concurrent.Api,                   Control.Eff.Concurrent.Api.Client,@@ -96,6 +109,7 @@                      GADTs,                      GeneralizedNewtypeDeriving,                      LambdaCase,+                     OverloadedStrings,                      MultiParamTypeClasses,                      RankNTypes,                      ScopedTypeVariables,@@ -120,6 +134,7 @@               , extensible-effects-concurrent               , extensible-effects               , lens+              , text   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -131,6 +146,7 @@                       , GADTs                       , GeneralizedNewtypeDeriving                       , LambdaCase+                      , OverloadedStrings                       , RankNTypes                       , ScopedTypeVariables                       , StandaloneDeriving@@ -148,6 +164,7 @@               , extensible-effects-concurrent               , extensible-effects               , lens+              , text   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -166,6 +183,7 @@                       , TypeApplications                       , TypeFamilies                       , TypeOperators+                      , OverloadedStrings  executable extensible-effects-concurrent-example-3   main-is: Main.hs@@ -178,6 +196,7 @@               , extensible-effects               , filepath               , lens+              , text   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -189,6 +208,7 @@                       , GADTs                       , GeneralizedNewtypeDeriving                       , LambdaCase+                      , OverloadedStrings                       , RankNTypes                       , ScopedTypeVariables                       , StandaloneDeriving@@ -205,6 +225,7 @@               , extensible-effects-concurrent               , extensible-effects               , deepseq+              , text   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -216,6 +237,7 @@                       , GADTs                       , GeneralizedNewtypeDeriving                       , LambdaCase+                      , OverloadedStrings                       , RankNTypes                       , ScopedTypeVariables                       , StandaloneDeriving@@ -237,6 +259,7 @@               , LoopTests               , ProcessBehaviourTestCases               , SingleThreadedScheduler+              , LogMessageIdeaTest   ghc-options: -Wall -threaded -fno-full-laziness   build-depends:                 async@@ -253,16 +276,22 @@               , lens               , HUnit               , stm+              , text+              , time+              , filepath+              , hostname   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns                       , DataKinds+                      , DeriveGeneric                       , FlexibleContexts                       , FlexibleInstances                       , FunctionalDependencies                       , GADTs                       , GeneralizedNewtypeDeriving                       , LambdaCase+                      , OverloadedStrings                       , RankNTypes                       , ScopedTypeVariables                       , StandaloneDeriving

@@ -37,6 +37,31 @@     -- ** Logging Effect     module Control.Eff.Log   ,+    -- ** Log Writer+    -- *** Asynchronous+    module Control.Eff.LogWriter.Async+  ,+    -- *** Console+    module Control.Eff.LogWriter.Console+  ,+    -- *** File+    module Control.Eff.LogWriter.File+  ,+    -- *** UDP+    module Control.Eff.LogWriter.UDP++  , -- *** Non-IO Log Message Capturing+    module Control.Eff.LogWriter.Capture++  , -- *** "Debug.Trace"+    module Control.Eff.LogWriter.DebugTrace++  , -- *** Generic IO+    module Control.Eff.LogWriter.IO++  , -- *** Unix Domain Socket+    module Control.Eff.LogWriter.UnixSocket+  ,     -- ** Preventing Space Leaks     module Control.Eff.Loop   )@@ -226,4 +251,12 @@                                                 , defaultMainSingleThreaded                                                 ) import           Control.Eff.Log+import           Control.Eff.LogWriter.Async+import           Control.Eff.LogWriter.Capture+import           Control.Eff.LogWriter.Console+import           Control.Eff.LogWriter.DebugTrace+import           Control.Eff.LogWriter.File+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.UDP+import           Control.Eff.LogWriter.UnixSocket import           Control.Eff.Loop

@@ -22,6 +22,7 @@ import           Control.Monad.IO.Class import           Control.Monad                  ( unless ) import           Data.Typeable+import qualified Data.Text                     as T import           GHC.Stack  -- | Contains a 'TBQueue' capturing observations.@@ -31,8 +32,8 @@ -- | A 'Reader' for an 'ObservationQueue'. type ObservationQueueReader a = Reader (ObservationQueue a) -logPrefix :: forall o proxy . (HasCallStack, Typeable o) => proxy o -> String-logPrefix px = "observation queue: " ++ show (typeRep px)+logPrefix :: forall o proxy . (HasCallStack, Typeable o) => proxy o -> T.Text+logPrefix px = "observation queue: " <> T.pack (show (typeRep px))  -- | Read queued observations captured and enqueued in the shared 'TBQueue' by 'spawnLinkObservationQueueWriter'. -- This blocks until something was captured or an interrupt or exceptions was thrown. For a non-blocking@@ -120,8 +121,8 @@   rest <- lift (atomically (flushTBQueue q))   unless     (null rest)-    (logNotice (logPrefix (Proxy @o) ++ " unread observations: " ++ show rest))-  either (\em -> logError (show em) >> lift (throwIO em)) return res+    (logNotice (logPrefix (Proxy @o) <> " unread observations: " <> T.pack (show rest)))+  either (\em -> logError (T.pack (show em)) >> lift (throwIO em)) return res  -- | Spawn a process that can be used as an 'Observer' that enqueues the observations into an --   'ObservationQueue'. See 'withObservationQueue' for an example.

@@ -37,6 +37,7 @@   ) where +import           Control.Applicative import           Control.Eff import           Control.Eff.Extend import           Control.Eff.Log@@ -44,15 +45,15 @@ import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process+import           Control.DeepSeq import           Control.Monad                  ( (>=>) )-import           Data.Proxy+import           Data.Default import           Data.Dynamic-import           Control.Applicative-import           GHC.Stack-import           Control.DeepSeq-import           Data.Kind import           Data.Foldable-import           Data.Default+import           Data.Kind+import           Data.Proxy+import           Data.Text as T+import           GHC.Stack  -- | /Serve/ an 'Api' in a newly spawned process. --@@ -416,7 +417,7 @@ -- @since 0.13.2 exitOnUnhandled :: forall eff . HasCallStack => MessageCallback '[] eff exitOnUnhandled = MessageCallback selectAnyMessageLazy $ \msg ->-  return (StopServer (ProcessError ("unhandled message " ++ show msg)))+  return (StopServer (ProcessError ("unhandled message " <> show msg)))  -- | A 'fallbackHandler' that drops the left-over messages. --@@ -426,7 +427,7 @@    . (Member Logs eff, HasCallStack)   => MessageCallback '[] eff logUnhandledMessages = MessageCallback selectAnyMessageLazy $ \msg -> do-  logWarning ("ignoring unhandled message " ++ show msg)+  logWarning ("ignoring unhandled message " <> T.pack (show msg))   return AwaitNext  

@@ -131,6 +131,8 @@ import           Data.Function import           Control.Applicative import           Data.Maybe+import           Data.String                    (fromString)+import qualified Data.Text                     as T import qualified Control.Exception             as Exc  -- | The process effect is the basis for message passing concurrency. This@@ -158,44 +160,44 @@ -- * when the first process exists, all process should be killed immediately data Process (r :: [Type -> Type]) b where   -- | Remove all messages from the process' message queue-  FlushMessages :: Process r (ResumeProcess [Dynamic])+  FlushMessages ::Process r (ResumeProcess [Dynamic])   -- | In cooperative schedulers, this will give processing time to the   -- scheduler. Every other operation implicitly serves the same purpose.   --   -- @since 0.12.0-  YieldProcess :: Process r (ResumeProcess ())+  YieldProcess ::Process r (ResumeProcess ())   -- | Return the current 'ProcessId'-  SelfPid :: Process r (ResumeProcess ProcessId)+  SelfPid ::Process r (ResumeProcess ProcessId)   -- | Start a new process, the new process will execute an effect, the function   -- will return immediately with a 'ProcessId'.-  Spawn :: Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)+  Spawn ::Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)   -- | Start a new process, and 'Link' to it .   --   -- @since 0.12.0-  SpawnLink :: Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)+  SpawnLink ::Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)   -- | Get the process state (or 'Nothing' if the process is dead)-  GetProcessState :: ProcessId -> Process r (ResumeProcess (Maybe ProcessState))+  GetProcessState ::ProcessId -> Process r (ResumeProcess (Maybe ProcessState))   -- | Shutdown the process; irregardless of the exit reason, this function never   -- returns,-  Shutdown :: ExitReason 'NoRecovery   -> Process r a+  Shutdown ::ExitReason 'NoRecovery   -> Process r a   -- | Raise an error, that can be handled.-  SendShutdown :: ProcessId  -> ExitReason 'NoRecovery  -> Process r (ResumeProcess ())+  SendShutdown ::ProcessId  -> ExitReason 'NoRecovery  -> Process r (ResumeProcess ())   -- | Request that another a process interrupts. The targeted process is interrupted   -- and gets an 'Interrupted', the target process may decide to ignore the   -- interrupt and continue as if nothing happened.-  SendInterrupt :: ProcessId -> InterruptReason -> Process r (ResumeProcess ())+  SendInterrupt ::ProcessId -> InterruptReason -> Process r (ResumeProcess ())   -- | Send a message to a process addressed by the 'ProcessId'. Sending a   -- message should __always succeed__ and return __immediately__, even if the   -- destination process does not exist, or does not accept messages of the   -- given type.-  SendMessage :: ProcessId -> Dynamic -> Process r (ResumeProcess ())+  SendMessage ::ProcessId -> Dynamic -> Process r (ResumeProcess ())   -- | Receive a message that matches a criteria.   -- This should block until an a message was received. The message is returned   -- as a 'ResumeProcess' value. The function should also return if an exception   -- was caught or a shutdown was requested.   ReceiveSelectedMessage :: forall r a . MessageSelector a -> Process r (ResumeProcess a)   -- | Generate a unique 'Int' for the current process.-  MakeReference :: Process r (ResumeProcess Int)+  MakeReference ::Process r (ResumeProcess Int)   -- | Monitor another process. When the monitored process exits a   --  'ProcessDown' is sent to the calling process.   -- The return value is a unique identifier for that monitor.@@ -205,21 +207,21 @@   -- will be sent immediately, without exit reason   --   -- @since 0.12.0-  Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference)+  Monitor ::ProcessId -> Process r (ResumeProcess MonitorReference)   -- | Remove a monitor.   --   -- @since 0.12.0-  Demonitor :: MonitorReference -> Process r (ResumeProcess ())+  Demonitor ::MonitorReference -> Process r (ResumeProcess ())   -- | Connect the calling process to another process, such that   -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other   -- is shutdown with the 'ExitReason' 'LinkedProcessCrashed'.   --   -- @since 0.12.0-  Link :: ProcessId -> Process r (ResumeProcess ())+  Link ::ProcessId -> Process r (ResumeProcess ())   -- | Unlink the calling process from the other process.   --   -- @since 0.12.0-  Unlink :: ProcessId -> Process r (ResumeProcess ())+  Unlink ::ProcessId -> Process r (ResumeProcess ())  instance Show (Process r b) where   showsPrec d = \case@@ -266,9 +268,9 @@   -- | The current operation of the process was interrupted with a   -- 'ExitReason'. If 'isRecoverable' holds for the given reason,   -- the process may choose to continue.-  Interrupted :: InterruptReason -> ResumeProcess v+  Interrupted ::InterruptReason -> ResumeProcess v   -- | The process may resume to do work, using the given result.-  ResumeWith :: a -> ResumeProcess a+  ResumeWith ::a -> ResumeProcess a   deriving ( Typeable, Generic, Generic1, Show )  instance NFData a => NFData (ResumeProcess a)@@ -395,11 +397,11 @@ -- scheduler implementation. data SchedulerProxy :: [Type -> Type] -> Type where   -- | Tell the type checker what effects we have below 'Process'-  SchedulerProxy :: SchedulerProxy q+  SchedulerProxy ::SchedulerProxy q   -- | Like 'SchedulerProxy' but shorter-  SP :: SchedulerProxy q+  SP ::SchedulerProxy q   -- | Like 'SP' but different-  Scheduler :: SchedulerProxy q+  Scheduler ::SchedulerProxy q  -- | /Cons/ 'Process' onto a list of effects. type ConsProcess r = Process r ': r@@ -491,29 +493,29 @@     --     -- @since 0.13.2     ProcessFinished-      :: ExitReason 'Recoverable+      ::ExitReason 'Recoverable     -- | A process that should be running was not running.     ProcessNotRunning-      :: ProcessId -> ExitReason 'Recoverable+      ::ProcessId -> ExitReason 'Recoverable     -- | A linked process is down     LinkedProcessCrashed-      :: ProcessId -> ExitReason 'Recoverable+      ::ProcessId -> ExitReason 'Recoverable     -- | An exit reason that has an error message but isn't 'Recoverable'.     ProcessError-      :: String -> ExitReason 'Recoverable+      ::String -> ExitReason 'Recoverable     -- | A process function returned or exited without any error.     ExitNormally-      :: ExitReason 'NoRecovery+      ::ExitReason 'NoRecovery     -- | An unhandled 'Recoverable' allows 'NoRecovery'.     NotRecovered-      :: (ExitReason 'Recoverable) -> ExitReason 'NoRecovery+      ::(ExitReason 'Recoverable) -> ExitReason 'NoRecovery     -- | An unexpected runtime exception was thrown, i.e. an exception     --    derived from 'Control.Exception.Safe.SomeException'     UnexpectedException-      :: String -> String -> ExitReason 'NoRecovery+      ::String -> String -> ExitReason 'NoRecovery     -- | A process was cancelled (e.g. killed, in 'Async.cancel')     Killed-      :: ExitReason 'NoRecovery+      ::ExitReason 'NoRecovery   deriving Typeable  instance Show (ExitReason x) where@@ -638,7 +640,8 @@ -- | Handle interrupts by logging them with `logProcessExit` and otherwise -- ignoring them. logInterrupts-  :: forall r . (Member Logs r, HasCallStack, Member Interrupts r)+  :: forall r+   . (Member Logs r, HasCallStack, Member Interrupts r)   => Eff r ()   -> Eff r () logInterrupts = handleInterrupts logProcessExit@@ -686,7 +689,7 @@  -- | An existential wrapper around 'ExitReason' data SomeExitReason where-  SomeExitReason :: ExitReason x -> SomeExitReason+  SomeExitReason ::ExitReason x -> SomeExitReason  instance Ord SomeExitReason where   compare = compare `on` fromSomeExitReason@@ -726,14 +729,15 @@ -- -- > logCrash = traverse_ logError . toCrashReason ---toCrashReason :: ExitReason x -> Maybe String-toCrashReason e | isCrash e = Just (show e)+toCrashReason :: ExitReason x -> Maybe T.Text+toCrashReason e | isCrash e = Just (T.pack (show e))                 | otherwise = Nothing  -- | Log the 'ExitReason's-logProcessExit :: forall e x. (Member Logs e, HasCallStack) => ExitReason x -> Eff e ()+logProcessExit+  :: forall e x . (Member Logs e, HasCallStack) => ExitReason x -> Eff e () logProcessExit (toCrashReason -> Just ex) = withFrozenCallStack (logError ex)-logProcessExit ex = withFrozenCallStack (logDebug (show ex))+logProcessExit ex = withFrozenCallStack (logDebug (fromString (show ex)))   -- | Execute a and action and return the result;

@@ -18,37 +18,47 @@   , InterruptableProcEff   , SchedulerIO   , HasSchedulerIO-  ) where+  )+where -import Control.Concurrent (yield)-import qualified Control.Concurrent.Async as Async-import Control.Concurrent.Async (Async(..))-import Control.Concurrent.STM as STM-import Control.Eff-import Control.Eff.Concurrent.Process-import qualified Control.Eff.ExceptionExtra as ExcExtra ()-import Control.Eff.Extend-import Control.Eff.Log-import Control.Eff.Reader.Strict as Reader-import Control.Exception.Safe as Safe-import Control.Lens-import Control.Monad (void, when)-import Control.Monad.Trans.Control (MonadBaseControl(..), control)-import Data.Default-import Data.Dynamic-import Data.Foldable-import Data.Function (fix)-import Data.Kind ()-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Sequence (Seq(..))-import qualified Data.Sequence as Seq-import Data.Set (Set)-import qualified Data.Set as Set-import GHC.Stack-import System.Timeout-import Text.Printf+import           Control.Concurrent             ( yield )+import qualified Control.Concurrent.Async      as Async+import           Control.Concurrent.Async       ( Async(..) )+import           Control.Concurrent.STM        as STM+import           Control.Eff+import           Control.Eff.Concurrent.Process+import qualified Control.Eff.ExceptionExtra    as ExcExtra+                                                ( )+import           Control.Eff.Extend+import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.Console+import           Control.Eff.LogWriter.Async+import           Control.Eff.Reader.Strict     as Reader+import           Control.Exception.Safe        as Safe+import           Control.Lens+import           Control.Monad                  ( void+                                                , when+                                                )+import           Control.Monad.Trans.Control    ( MonadBaseControl(..)+                                                , control+                                                )+import           Data.Default+import           Data.Dynamic+import           Data.Foldable+import           Data.Function                  ( fix )+import           Data.Kind                      ( )+import           Data.Map                       ( Map )+import qualified Data.Map                      as Map+import           Data.Maybe+import           Data.Sequence                  ( Seq(..) )+import qualified Data.Sequence                 as Seq+import           Data.Set                       ( Set )+import qualified Data.Set                      as Set+import qualified Data.Text                     as T+import           GHC.Stack+import           System.Timeout+import           Text.Printf  -- * Process Types @@ -69,7 +79,8 @@ tryTakeNextShutdownRequestSTM :: TVar MessageQ -> STM (Maybe SomeExitReason) tryTakeNextShutdownRequestSTM mqVar = do   mq <- readTVar mqVar-  when (isJust (mq ^. shutdownRequests)) (writeTVar mqVar (mq & shutdownRequests .~ Nothing))+  when (isJust (mq ^. shutdownRequests))+       (writeTVar mqVar (mq & shutdownRequests .~ Nothing))   return (mq ^. shutdownRequests)  -- | Information about a process, needed to implement@@ -86,8 +97,8 @@  -- * Scheduler Types --- | Contains all process info'elements, as well as the state needed to--- implement inter process communication.+-- | Contains all process info'elements, as well as the state needed to implement+-- inter-process communication. data SchedulerState = SchedulerState   { _nextPid :: TVar ProcessId   , _processTable :: TVar (Map ProcessId ProcessInfo)@@ -100,7 +111,8 @@  -- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the -- owners message queue-addMonitoring :: ProcessId -> ProcessId -> SchedulerState -> STM MonitorReference+addMonitoring+  :: ProcessId -> ProcessId -> SchedulerState -> STM MonitorReference addMonitoring target owner schedulerState = do   aNewMonitorIndex <- readTVar (schedulerState ^. nextMonitorIndex)   modifyTVar' (schedulerState ^. nextMonitorIndex) (+ 1)@@ -108,26 +120,34 @@   when (target /= owner) $ do     pt <- readTVar (schedulerState ^. processTable)     if Map.member target pt-      then modifyTVar' (schedulerState ^. processMonitors) (Set.insert (monitorRef, owner))-      else let processDownMessage = ProcessDown monitorRef (SomeExitReason (ProcessNotRunning target))-            in enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState+      then modifyTVar' (schedulerState ^. processMonitors)+                       (Set.insert (monitorRef, owner))+      else+        let processDownMessage =+              ProcessDown monitorRef (SomeExitReason (ProcessNotRunning target))+        in  enqueueMessageOtherProcess owner+                                       (toDyn processDownMessage)+                                       schedulerState   return monitorRef  removeMonitoring :: MonitorReference -> SchedulerState -> STM ()-removeMonitoring monitorRef schedulerState =-  modifyTVar' (schedulerState ^. processMonitors) (Set.filter (\(ref, _) -> ref /= monitorRef))+removeMonitoring monitorRef schedulerState = modifyTVar'+  (schedulerState ^. processMonitors)+  (Set.filter (\(ref, _) -> ref /= monitorRef)) -triggerAndRemoveMonitor :: ProcessId -> SomeExitReason -> SchedulerState -> STM ()+triggerAndRemoveMonitor+  :: ProcessId -> SomeExitReason -> SchedulerState -> STM () triggerAndRemoveMonitor downPid reason schedulerState = do   monRefs <- readTVar (schedulerState ^. processMonitors)   traverse_ go monRefs-  where-    go (mr, owner) =-      when-        (monitoredProcess mr == downPid)-        (do let processDownMessage = ProcessDown mr reason-            enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState-            removeMonitoring mr schedulerState)+ where+  go (mr, owner) = when+    (monitoredProcess mr == downPid)+    (do+      let processDownMessage = ProcessDown mr reason+      enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState+      removeMonitoring mr schedulerState+    )  -- * Process Implementation instance Show ProcessInfo where@@ -135,48 +155,73 @@  -- | Create a new 'ProcessInfo' newProcessInfo :: HasCallStack => ProcessId -> STM ProcessInfo-newProcessInfo a = ProcessInfo a <$> newTVar ProcessBooting <*> newTVar def <*> newTVar def+newProcessInfo a =+  ProcessInfo a <$> newTVar ProcessBooting <*> newTVar def <*> newTVar def  -- * Scheduler Implementation  -- | Create a new 'SchedulerState' newSchedulerState :: HasCallStack => STM SchedulerState-newSchedulerState = SchedulerState <$> newTVar 1 <*> newTVar def <*> newTVar def <*> newTVar def <*> newTVar def+newSchedulerState =+  SchedulerState+    <$> newTVar 1+    <*> newTVar def+    <*> newTVar def+    <*> newTVar def+    <*> newTVar def  -- | Create a new 'SchedulerState' run an IO action, catching all exceptions, -- and when the actions returns, clean up and kill all processes.-withNewSchedulerState :: (HasCallStack) => Eff SchedulerIO () -> Eff LoggingAndIo ()-withNewSchedulerState mainProcessAction =-  Safe.bracketWithError-    (lift (atomically newSchedulerState))-    (\exceptions schedulerState -> do-       traverse_ (logError . ("scheduler setup crashed with: " ++) . Safe.displayException) exceptions-       logDebug "scheduler cleanup begin"-       runReader schedulerState tearDownScheduler)-    (\schedulerState -> do-       logDebug "scheduler loop entered"-       x <- runReader schedulerState mainProcessAction-       logDebug "scheduler loop returned"-       return x)-  where-    tearDownScheduler :: Eff SchedulerIO ()-    tearDownScheduler = do-      schedulerState <- getSchedulerState-      let cancelTableVar = schedulerState ^. processCancellationTable-      -- cancel all processes-      allProcesses <- lift (atomically (readTVar cancelTableVar <* writeTVar cancelTableVar def))-      logNotice ("cancelling processes: " ++ show (toListOf (ifolded . asIndex) allProcesses))-      void-        (liftBaseWith-           (\runS ->-              timeout-                5000000-                (Async.mapConcurrently-                   (\a -> do-                      Async.cancel a-                      runS (logNotice ("process cancelled: " ++ show (asyncThreadId a))))-                   allProcesses >>-                 runS (logNotice "all processes cancelled"))))+withNewSchedulerState+  :: (HasCallStack) => Eff SchedulerIO () -> Eff LoggingAndIo ()+withNewSchedulerState mainProcessAction = Safe.bracketWithError+  (lift (atomically newSchedulerState))+  (\exceptions schedulerState -> do+    traverse_+      ( logError+      . ("scheduler setup crashed with: " <>)+      . T.pack+      . Safe.displayException+      )+      exceptions+    logDebug "scheduler cleanup begin"+    runReader schedulerState tearDownScheduler+  )+  (\schedulerState -> do+    logDebug "scheduler loop entered"+    x <- runReader schedulerState mainProcessAction+    logDebug "scheduler loop returned"+    return x+  )+ where+  tearDownScheduler :: Eff SchedulerIO ()+  tearDownScheduler = do+    schedulerState <- getSchedulerState+    let cancelTableVar = schedulerState ^. processCancellationTable+    -- cancel all processes+    allProcesses <- lift+      (atomically (readTVar cancelTableVar <* writeTVar cancelTableVar def))+    logNotice+      (  "cancelling processes: "+      <> T.pack (show (toListOf (ifolded . asIndex) allProcesses))+      )+    void+      (liftBaseWith+        (\runS -> timeout+          5000000+          (  Async.mapConcurrently+              (\a -> do+                Async.cancel a+                runS+                  (logNotice+                    ("process cancelled: " <> T.pack (show (asyncThreadId a)))+                  )+              )+              allProcesses+          >> runS (logNotice "all processes cancelled")+          )+        )+      )  -- | The concrete list of 'Eff'ects of processes compatible with this scheduler. -- This builds upon 'SchedulerIO'.@@ -199,252 +244,291 @@  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output.-defaultMainWithLogWriter :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO ()+defaultMainWithLogWriter+  :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO () defaultMainWithLogWriter lw =-  runLift . withSomeLogging . withAsyncLogging (1024 :: Int) lw . schedule+  runLift . withLogging lw . withAsyncLogWriter (1024 :: Int) . schedule  -- ** Process Execution -handleProcess ::-     (HasCallStack) => ProcessInfo -> Eff ProcEff (ExitReason 'NoRecovery) -> Eff SchedulerIO (ExitReason 'NoRecovery)-handleProcess myProcessInfo actionToRun =-  fix (handle_relay' singleStep (const . const (return ExitNormally))) actionToRun 0-  where-    singleStep ::-         (Eff ProcEff xx -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery)))-      -> Arrs ProcEff x xx-      -> Process SchedulerIO x-      -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery))-    singleStep k q p !nextRef = stepProcessInterpreter nextRef p (\nextNextRef x -> k (qApp q x) nextNextRef) return-    myPid = myProcessInfo ^. processId-    myProcessStateVar = myProcessInfo ^. processState-    setMyProcessState = lift . atomically . setMyProcessStateSTM-  -- DEBUG variant:-  -- setMyProcessState st = do-  --  oldSt <- lift (atomically (readTVar myProcessStateVar <* setMyProcessStateSTM st))-  --  logDebug ("state change: "++ show oldSt ++ " -> " ++ show st)-    setMyProcessStateSTM = writeTVar myProcessStateVar-    myMessageQVar = myProcessInfo ^. messageQ-    kontinueWith ::-         forall s v a. HasCallStack-      => (s -> Arr SchedulerIO v a)-      -> (s -> Arr SchedulerIO v a)-    kontinueWith kontinue !nextRef !result = do-      setMyProcessState ProcessIdle-      lift yield-      kontinue nextRef result-    diskontinueWith ::-         forall a. HasCallStack-      => Arr SchedulerIO (ExitReason 'NoRecovery) a-      -> Arr SchedulerIO (ExitReason 'NoRecovery) a-    diskontinueWith diskontinue !reason = do+handleProcess+  :: (HasCallStack)+  => ProcessInfo+  -> Eff ProcEff (ExitReason 'NoRecovery)+  -> Eff SchedulerIO (ExitReason 'NoRecovery)+handleProcess myProcessInfo actionToRun = fix+  (handle_relay' singleStep (const . const (return ExitNormally)))+  actionToRun+  0+ where+  singleStep+    :: (Eff ProcEff xx -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery)))+    -> Arrs ProcEff x xx+    -> Process SchedulerIO x+    -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery))+  singleStep k q p !nextRef = stepProcessInterpreter+    nextRef+    p+    (\nextNextRef x -> k (qApp q x) nextNextRef)+    return+  myPid                = myProcessInfo ^. processId+  myProcessStateVar    = myProcessInfo ^. processState+  setMyProcessState    = lift . atomically . setMyProcessStateSTM+-- DEBUG variant:+-- setMyProcessState st = do+--  oldSt <- lift (atomically (readTVar myProcessStateVar <* setMyProcessStateSTM st))+--  logDebug ("state change: "<> show oldSt <> " -> " <> show st)+  setMyProcessStateSTM = writeTVar myProcessStateVar+  myMessageQVar        = myProcessInfo ^. messageQ+  kontinueWith+    :: forall s v a+     . HasCallStack+    => (s -> Arr SchedulerIO v a)+    -> (s -> Arr SchedulerIO v a)+  kontinueWith kontinue !nextRef !result = do+    setMyProcessState ProcessIdle+    lift yield+    kontinue nextRef result+  diskontinueWith+    :: forall a+     . HasCallStack+    => Arr SchedulerIO (ExitReason 'NoRecovery) a+    -> Arr SchedulerIO (ExitReason 'NoRecovery) a+  diskontinueWith diskontinue !reason = do+    setMyProcessState ProcessShuttingDown+    diskontinue reason+  stepProcessInterpreter+    :: forall v a+     . HasCallStack+    => Int+    -> Process SchedulerIO v+    -> (Int -> Arr SchedulerIO v a)+    -> Arr SchedulerIO (ExitReason 'NoRecovery) a+    -> Eff SchedulerIO a+  stepProcessInterpreter !nextRef !request kontinue diskontinue =+    tryTakeNextShutdownRequest >>= maybe+      noShutdownRequested+      (either onShutdownRequested onInterruptRequested . fromSomeExitReason)+    -- handle process shutdown requests:+    --   1. take process exit reason+    --   2. set process state to ProcessShuttingDown+    --   3. apply kontinue to (Right Interrupted)+    --+   where+    tryTakeNextShutdownRequest =+      lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))+    onShutdownRequested shutdownRequest = do+      logDebug ("shutdown requested: " <> T.pack (show shutdownRequest))       setMyProcessState ProcessShuttingDown-      diskontinue reason-    stepProcessInterpreter ::-         forall v a. HasCallStack-      => Int-      -> Process SchedulerIO v-      -> (Int -> Arr SchedulerIO v a)-      -> Arr SchedulerIO (ExitReason 'NoRecovery) a-      -> Eff SchedulerIO a-    stepProcessInterpreter !nextRef !request kontinue diskontinue-      -- handle process shutdown requests:-      --   1. take process exit reason-      --   2. set process state to ProcessShuttingDown-      --   3. apply kontinue to (Right Interrupted)-      ---     =-      tryTakeNextShutdownRequest >>=-      maybe noShutdownRequested (either onShutdownRequested onInterruptRequested . fromSomeExitReason)-      where-        tryTakeNextShutdownRequest = lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))-        onShutdownRequested shutdownRequest = do-          logDebug ("shutdown requested: " ++ show shutdownRequest)-          setMyProcessState ProcessShuttingDown-          interpretRequestAfterShutdownRequest (diskontinueWith diskontinue) shutdownRequest request-        onInterruptRequested interruptRequest = do-          logDebug ("interrupt requested: " ++ show interruptRequest)-          setMyProcessState ProcessShuttingDown-          interpretRequestAfterInterruptRequest-            (kontinueWith kontinue nextRef)-            (diskontinueWith diskontinue)-            interruptRequest-            request-        noShutdownRequested = do-          setMyProcessState ProcessBusy-          interpretRequest (kontinueWith kontinue) (diskontinueWith diskontinue) nextRef request-  -- This gets no nextRef and may not pass a Left value to the continuation.-  -- This forces the caller to defer the process exit to the next request-  -- and hence ensures that the scheduler code cannot forget to allow the-  -- client code to react to a shutdown request.-    interpretRequestAfterShutdownRequest ::-         forall v a. HasCallStack-      => Arr SchedulerIO (ExitReason 'NoRecovery) a-      -> ExitReason 'NoRecovery-      -> Process SchedulerIO v-      -> Eff SchedulerIO a-    interpretRequestAfterShutdownRequest diskontinue shutdownRequest =-      \case-        SendMessage _ _ -> diskontinue shutdownRequest-        SendInterrupt _ _ -> diskontinue shutdownRequest-        SendShutdown toPid r ->-          if toPid == myPid-            then diskontinue r-            else diskontinue shutdownRequest-        Spawn _ -> diskontinue shutdownRequest-        SpawnLink _ -> diskontinue shutdownRequest-        ReceiveSelectedMessage _ -> diskontinue shutdownRequest-        FlushMessages -> diskontinue shutdownRequest-        SelfPid -> diskontinue shutdownRequest-        MakeReference -> diskontinue shutdownRequest-        YieldProcess -> diskontinue shutdownRequest-        Shutdown r -> diskontinue r-        GetProcessState _ -> diskontinue shutdownRequest-        Monitor _ -> diskontinue shutdownRequest-        Demonitor _ -> diskontinue shutdownRequest-        Link _ -> diskontinue shutdownRequest-        Unlink _ -> diskontinue shutdownRequest-    interpretRequestAfterInterruptRequest ::-         forall v a. HasCallStack-      => Arr SchedulerIO v a-      -> Arr SchedulerIO (ExitReason 'NoRecovery) a-      -> ExitReason 'Recoverable-      -> Process SchedulerIO v-      -> Eff SchedulerIO a-    interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =-      \case-        SendMessage _ _ -> kontinue (Interrupted interruptRequest)-        SendInterrupt _ _ -> kontinue (Interrupted interruptRequest)-        SendShutdown toPid r ->-          if toPid == myPid-            then diskontinue r-            else kontinue (Interrupted interruptRequest)-        Spawn _ -> kontinue (Interrupted interruptRequest)-        SpawnLink _ -> kontinue (Interrupted interruptRequest)-        ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)-        FlushMessages -> kontinue (Interrupted interruptRequest)-        SelfPid -> kontinue (Interrupted interruptRequest)-        MakeReference -> kontinue (Interrupted interruptRequest)-        YieldProcess -> kontinue (Interrupted interruptRequest)-        Shutdown r -> diskontinue r-        GetProcessState _ -> kontinue (Interrupted interruptRequest)-        Monitor _ -> kontinue (Interrupted interruptRequest)-        Demonitor _ -> kontinue (Interrupted interruptRequest)-        Link _ -> kontinue (Interrupted interruptRequest)-        Unlink _ -> kontinue (Interrupted interruptRequest)-    interpretRequest ::-         forall v a. HasCallStack-      => (Int -> Arr SchedulerIO v a)-      -> Arr SchedulerIO (ExitReason 'NoRecovery) a-      -> Int-      -> Process SchedulerIO v-      -> Eff SchedulerIO a-    interpretRequest kontinue diskontinue nextRef =-      \case-        SendMessage toPid msg -> interpretSend toPid msg >>= kontinue nextRef . ResumeWith-        SendInterrupt toPid msg ->-          if toPid == myPid-            then kontinue nextRef (Interrupted msg)-            else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg) >>= kontinue nextRef . ResumeWith-        SendShutdown toPid msg ->-          if toPid == myPid-            then diskontinue msg-            else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg) >>= kontinue nextRef . ResumeWith-        Spawn child -> spawnNewProcess Nothing child >>= kontinue nextRef . ResumeWith . fst-        SpawnLink child -> spawnNewProcess (Just myProcessInfo) child >>= kontinue nextRef . ResumeWith . fst-        ReceiveSelectedMessage f -> interpretReceive f >>= either diskontinue (kontinue nextRef)-        FlushMessages -> interpretFlush >>= kontinue nextRef-        SelfPid -> kontinue nextRef (ResumeWith myPid)-        MakeReference -> kontinue (nextRef + 1) (ResumeWith nextRef)-        YieldProcess -> kontinue nextRef (ResumeWith ())-        Shutdown r -> diskontinue r-        GetProcessState toPid -> interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith-        Monitor target -> interpretMonitor target >>= kontinue nextRef . ResumeWith-        Demonitor ref -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith-        Link toPid -> interpretLink toPid >>= kontinue nextRef . either Interrupted ResumeWith-        Unlink toPid -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith-      where-        interpretMonitor !target = do-          setMyProcessState ProcessBusyMonitoring-          schedulerState <- getSchedulerState-          lift (atomically (addMonitoring target myPid schedulerState))-        interpretDemonitor !ref = do-          setMyProcessState ProcessBusyMonitoring-          schedulerState <- getSchedulerState-          lift (atomically (removeMonitoring ref schedulerState))-        interpretUnlink !toPid = do-          setMyProcessState ProcessBusyUnlinking-          schedulerState <- getSchedulerState-          let procInfoVar = schedulerState ^. processTable-          lift $-            atomically $ do-              procInfo <- readTVar procInfoVar-              traverse_-                (\toProcInfo -> modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid))-                (procInfo ^. at toPid)-              modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)-        interpretGetProcessState !toPid = do-          setMyProcessState ProcessBusy-          schedulerState <- getSchedulerState-          let procInfoVar = schedulerState ^. processTable-          lift $-            atomically $ do-              procInfoTable <- readTVar procInfoVar-              traverse (\toProcInfo -> readTVar (toProcInfo ^. processState)) (procInfoTable ^. at toPid)-        interpretLink !toPid = do-          setMyProcessState ProcessBusyLinking-          schedulerState <- getSchedulerState-          let procInfoVar = schedulerState ^. processTable-          lift $-            atomically $ do-              procInfoTable <- readTVar procInfoVar-              case procInfoTable ^. at toPid of-                Just toProcInfo -> do-                  modifyTVar' (toProcInfo ^. processLinks) (Set.insert myPid)-                  modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)-                  return (Right ())-                Nothing -> return (Left (LinkedProcessCrashed toPid))-        interpretSend !toPid msg =-          setMyProcessState ProcessBusySending *> getSchedulerState >>=-          lift . atomically . enqueueMessageOtherProcess toPid msg-        interpretSendShutdownOrInterrupt !toPid !msg =-          setMyProcessState-            (either (const ProcessBusySendingShutdown) (const ProcessBusySendingInterrupt) (fromSomeExitReason msg)) *>-          getSchedulerState >>=-          lift . atomically . enqueueShutdownRequest toPid msg-        interpretFlush :: Eff SchedulerIO (ResumeProcess [Dynamic])-        interpretFlush = do-          setMyProcessState ProcessBusyReceiving-          lift $-            atomically $ do-              myMessageQ <- readTVar myMessageQVar-              modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)-              return (ResumeWith (toList (myMessageQ ^. incomingMessages)))-        interpretReceive :: MessageSelector b -> Eff SchedulerIO (Either (ExitReason 'NoRecovery) (ResumeProcess b))-        interpretReceive f = do-          setMyProcessState ProcessBusyReceiving-          lift $-            atomically $ do-              myMessageQ <- readTVar myMessageQVar-              case myMessageQ ^. shutdownRequests of-                Nothing ->-                  case partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty of-                    Nothing -> retry-                    Just (selectedMessage, otherMessages) -> do-                      modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)-                      return (Right (ResumeWith selectedMessage))-                Just shutdownRequest -> do-                  modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)-                  case fromSomeExitReason shutdownRequest of-                    Left sr -> return (Left sr)-                    Right ir -> return (Right (Interrupted ir))-          where-            partitionMessages Seq.Empty _acc = Nothing-            partitionMessages (m :<| msgRest) acc =-              maybe-                (partitionMessages msgRest (acc :|> m))-                (\res -> Just (res, acc Seq.>< msgRest))-                (runMessageSelector f m)+      interpretRequestAfterShutdownRequest (diskontinueWith diskontinue)+                                           shutdownRequest+                                           request+    onInterruptRequested interruptRequest = do+      logDebug ("interrupt requested: " <> T.pack (show interruptRequest))+      setMyProcessState ProcessShuttingDown+      interpretRequestAfterInterruptRequest (kontinueWith kontinue nextRef)+                                            (diskontinueWith diskontinue)+                                            interruptRequest+                                            request+    noShutdownRequested = do+      setMyProcessState ProcessBusy+      interpretRequest (kontinueWith kontinue)+                       (diskontinueWith diskontinue)+                       nextRef+                       request+-- This gets no nextRef and may not pass a Left value to the continuation.+-- This forces the caller to defer the process exit to the next request+-- and hence ensures that the scheduler code cannot forget to allow the+-- client code to react to a shutdown request.+  interpretRequestAfterShutdownRequest+    :: forall v a+     . HasCallStack+    => Arr SchedulerIO (ExitReason 'NoRecovery) a+    -> ExitReason 'NoRecovery+    -> Process SchedulerIO v+    -> Eff SchedulerIO a+  interpretRequestAfterShutdownRequest diskontinue shutdownRequest = \case+    SendMessage   _ _ -> diskontinue shutdownRequest+    SendInterrupt _ _ -> diskontinue shutdownRequest+    SendShutdown toPid r ->+      if toPid == myPid then diskontinue r else diskontinue shutdownRequest+    Spawn                  _ -> diskontinue shutdownRequest+    SpawnLink              _ -> diskontinue shutdownRequest+    ReceiveSelectedMessage _ -> diskontinue shutdownRequest+    FlushMessages            -> diskontinue shutdownRequest+    SelfPid                  -> diskontinue shutdownRequest+    MakeReference            -> diskontinue shutdownRequest+    YieldProcess             -> diskontinue shutdownRequest+    Shutdown        r        -> diskontinue r+    GetProcessState _        -> diskontinue shutdownRequest+    Monitor         _        -> diskontinue shutdownRequest+    Demonitor       _        -> diskontinue shutdownRequest+    Link            _        -> diskontinue shutdownRequest+    Unlink          _        -> diskontinue shutdownRequest+  interpretRequestAfterInterruptRequest+    :: forall v a+     . HasCallStack+    => Arr SchedulerIO v a+    -> Arr SchedulerIO (ExitReason 'NoRecovery) a+    -> ExitReason 'Recoverable+    -> Process SchedulerIO v+    -> Eff SchedulerIO a+  interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =+    \case+      SendMessage   _     _ -> kontinue (Interrupted interruptRequest)+      SendInterrupt _     _ -> kontinue (Interrupted interruptRequest)+      SendShutdown  toPid r -> if toPid == myPid+        then diskontinue r+        else kontinue (Interrupted interruptRequest)+      Spawn                  _ -> kontinue (Interrupted interruptRequest)+      SpawnLink              _ -> kontinue (Interrupted interruptRequest)+      ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)+      FlushMessages            -> kontinue (Interrupted interruptRequest)+      SelfPid                  -> kontinue (Interrupted interruptRequest)+      MakeReference            -> kontinue (Interrupted interruptRequest)+      YieldProcess             -> kontinue (Interrupted interruptRequest)+      Shutdown        r        -> diskontinue r+      GetProcessState _        -> kontinue (Interrupted interruptRequest)+      Monitor         _        -> kontinue (Interrupted interruptRequest)+      Demonitor       _        -> kontinue (Interrupted interruptRequest)+      Link            _        -> kontinue (Interrupted interruptRequest)+      Unlink          _        -> kontinue (Interrupted interruptRequest)+  interpretRequest+    :: forall v a+     . HasCallStack+    => (Int -> Arr SchedulerIO v a)+    -> Arr SchedulerIO (ExitReason 'NoRecovery) a+    -> Int+    -> Process SchedulerIO v+    -> Eff SchedulerIO a+  interpretRequest kontinue diskontinue nextRef = \case+    SendMessage toPid msg ->+      interpretSend toPid msg >>= kontinue nextRef . ResumeWith+    SendInterrupt toPid msg -> if toPid == myPid+      then kontinue nextRef (Interrupted msg)+      else+        interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)+        >>= kontinue nextRef+        .   ResumeWith+    SendShutdown toPid msg -> if toPid == myPid+      then diskontinue msg+      else+        interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)+        >>= kontinue nextRef+        .   ResumeWith+    Spawn child ->+      spawnNewProcess Nothing child >>= kontinue nextRef . ResumeWith . fst+    SpawnLink child ->+      spawnNewProcess (Just myProcessInfo) child+        >>= kontinue nextRef+        .   ResumeWith+        .   fst+    ReceiveSelectedMessage f ->+      interpretReceive f >>= either diskontinue (kontinue nextRef)+    FlushMessages -> interpretFlush >>= kontinue nextRef+    SelfPid       -> kontinue nextRef (ResumeWith myPid)+    MakeReference -> kontinue (nextRef + 1) (ResumeWith nextRef)+    YieldProcess  -> kontinue nextRef (ResumeWith ())+    Shutdown r    -> diskontinue r+    GetProcessState toPid ->+      interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith+    Monitor target ->+      interpretMonitor target >>= kontinue nextRef . ResumeWith+    Demonitor ref -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith+    Link toPid ->+      interpretLink toPid >>= kontinue nextRef . either Interrupted ResumeWith+    Unlink toPid -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith+   where+    interpretMonitor !target = do+      setMyProcessState ProcessBusyMonitoring+      schedulerState <- getSchedulerState+      lift (atomically (addMonitoring target myPid schedulerState))+    interpretDemonitor !ref = do+      setMyProcessState ProcessBusyMonitoring+      schedulerState <- getSchedulerState+      lift (atomically (removeMonitoring ref schedulerState))+    interpretUnlink !toPid = do+      setMyProcessState ProcessBusyUnlinking+      schedulerState <- getSchedulerState+      let procInfoVar = schedulerState ^. processTable+      lift $ atomically $ do+        procInfo <- readTVar procInfoVar+        traverse_+          (\toProcInfo ->+            modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid)+          )+          (procInfo ^. at toPid)+        modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)+    interpretGetProcessState !toPid = do+      setMyProcessState ProcessBusy+      schedulerState <- getSchedulerState+      let procInfoVar = schedulerState ^. processTable+      lift $ atomically $ do+        procInfoTable <- readTVar procInfoVar+        traverse (\toProcInfo -> readTVar (toProcInfo ^. processState))+                 (procInfoTable ^. at toPid)+    interpretLink !toPid = do+      setMyProcessState ProcessBusyLinking+      schedulerState <- getSchedulerState+      let procInfoVar = schedulerState ^. processTable+      lift $ atomically $ do+        procInfoTable <- readTVar procInfoVar+        case procInfoTable ^. at toPid of+          Just toProcInfo -> do+            modifyTVar' (toProcInfo ^. processLinks)    (Set.insert myPid)+            modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)+            return (Right ())+          Nothing -> return (Left (LinkedProcessCrashed toPid))+    interpretSend !toPid msg =+      setMyProcessState ProcessBusySending+        *>  getSchedulerState+        >>= lift+        .   atomically+        .   enqueueMessageOtherProcess toPid msg+    interpretSendShutdownOrInterrupt !toPid !msg =+      setMyProcessState+          (either (const ProcessBusySendingShutdown)+                  (const ProcessBusySendingInterrupt)+                  (fromSomeExitReason msg)+          )+        *>  getSchedulerState+        >>= lift+        .   atomically+        .   enqueueShutdownRequest toPid msg+    interpretFlush :: Eff SchedulerIO (ResumeProcess [Dynamic])+    interpretFlush = do+      setMyProcessState ProcessBusyReceiving+      lift $ atomically $ do+        myMessageQ <- readTVar myMessageQVar+        modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)+        return (ResumeWith (toList (myMessageQ ^. incomingMessages)))+    interpretReceive+      :: MessageSelector b+      -> Eff SchedulerIO (Either (ExitReason 'NoRecovery) (ResumeProcess b))+    interpretReceive f = do+      setMyProcessState ProcessBusyReceiving+      lift $ atomically $ do+        myMessageQ <- readTVar myMessageQVar+        case myMessageQ ^. shutdownRequests of+          Nothing ->+            case+                partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty+              of+                Nothing                               -> retry+                Just (selectedMessage, otherMessages) -> do+                  modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)+                  return (Right (ResumeWith selectedMessage))+          Just shutdownRequest -> do+            modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)+            case fromSomeExitReason shutdownRequest of+              Left  sr -> return (Left sr)+              Right ir -> return (Right (Interrupted ir))+     where+      partitionMessages Seq.Empty       _acc = Nothing+      partitionMessages (m :<| msgRest) acc  = maybe+        (partitionMessages msgRest (acc :|> m))+        (\res -> Just (res, acc Seq.>< msgRest))+        (runMessageSelector f m)  -- | This is the main entry point to running a message passing concurrency -- application. This function takes a 'Process' on top of the 'SchedulerIO'@@ -452,140 +536,174 @@ schedule :: (HasCallStack) => Eff InterruptableProcEff () -> Eff LoggingAndIo () schedule procEff =   liftBaseWith-    (\runS ->-       Async.withAsync-         (runS $-          withNewSchedulerState $ do-            (_, mainProcAsync) <--              spawnNewProcess Nothing $ do-                logNotice "++++++++ main process started ++++++++"-                provideInterruptsShutdown procEff-                logNotice "++++++++ main process returned ++++++++"-            lift (void (Async.wait mainProcAsync)))-         (\ast ->-            runS $ do-              a <- restoreM ast-              void $ lift (Async.wait a))) >>=-  restoreM+      (\runS -> Async.withAsync+        (runS $ withNewSchedulerState $ do+          (_, mainProcAsync) <- spawnNewProcess Nothing $ do+            logNotice "++++++++ main process started ++++++++"+            provideInterruptsShutdown procEff+            logNotice "++++++++ main process returned ++++++++"+          lift (void (Async.wait mainProcAsync))+        )+        (\ast -> runS $ do+          a <- restoreM ast+          void $ lift (Async.wait a)+        )+      )+    >>= restoreM -spawnNewProcess ::-     (HasCallStack)+spawnNewProcess+  :: (HasCallStack)   => Maybe ProcessInfo   -> Eff ProcEff ()   -> Eff SchedulerIO (ProcessId, Async (ExitReason 'NoRecovery)) spawnNewProcess mLinkedParent mfa = do   schedulerState <- getSchedulerState-  procInfo <- allocateProcInfo schedulerState+  procInfo       <- allocateProcInfo schedulerState   traverse_ (linkToParent procInfo) mLinkedParent   procAsync <- doForkProc procInfo schedulerState   return (procInfo ^. processId, procAsync)-  where-    linkToParent toProcInfo parent = do-      let toPid = toProcInfo ^. processId-          parentPid = parent ^. processId-      lift $-        atomically $ do-          modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)-          modifyTVar' (parent ^. processLinks) (Set.insert toPid)-    allocateProcInfo schedulerState =-      lift-        (atomically-           (do let nextPidVar = schedulerState ^. nextPid-                   processInfoVar = schedulerState ^. processTable-               pid <- readTVar nextPidVar-               modifyTVar' nextPidVar (+ 1)-               procInfo <- newProcessInfo pid-               modifyTVar' processInfoVar (at pid ?~ procInfo)-               return procInfo))-    logAppendProcInfo pid =-      let addProcessId = over lmProcessId (maybe (Just (printf "% 9s" (show pid))) Just)-       in censorLogs @IO addProcessId-    triggerProcessLinksAndMonitors :: ProcessId -> ExitReason e -> TVar (Set ProcessId) -> Eff SchedulerIO ()-    triggerProcessLinksAndMonitors !pid !reason !linkSetVar = do-      schedulerState <- getSchedulerState-      lift $ atomically $ triggerAndRemoveMonitor pid (SomeExitReason reason) schedulerState-      let exitSeverity = toExitSeverity reason-          sendIt !linkedPid = do-            let msg = SomeExitReason (LinkedProcessCrashed pid)-            lift $-              atomically $ do-                procInfoTable <- readTVar (schedulerState ^. processTable)-                let mLinkedProcInfo = procInfoTable ^? ix linkedPid-                case mLinkedProcInfo of-                  Nothing -> return (Left linkedPid)-                  Just linkedProcInfo ->-                    let linkedMsgQVar = linkedProcInfo ^. messageQ-                        linkedLinkSetVar = linkedProcInfo ^. processLinks-                     in do linkedLinkSet <- readTVar linkedLinkSetVar-                           if Set.member pid linkedLinkSet-                             then do-                               writeTVar linkedLinkSetVar (Set.delete pid linkedLinkSet)-                               when (exitSeverity == Crash) (modifyTVar' linkedMsgQVar (shutdownRequests ?~ msg))-                               return (Right linkedPid)-                             else return (Left linkedPid)-      linkedPids <--        lift-          (atomically-             (do linkSet <- readTVar linkSetVar-                 writeTVar linkSetVar def-                 return linkSet))-      res <- traverse sendIt (toList linkedPids)-      traverse_-        (logDebug . either (("linked process no found: " ++) . show) (("sent shutdown to linked process: " ++) . show))-        res-    doForkProc :: ProcessInfo -> SchedulerState -> Eff SchedulerIO (Async (ExitReason 'NoRecovery))-    doForkProc procInfo schedulerState =-      control-        (\inScheduler -> do-           let cancellationsVar = schedulerState ^. processCancellationTable-               processInfoVar = schedulerState ^. processTable-               pid = procInfo ^. processId-           procAsync <--             Async.async-               (inScheduler-                  (logAppendProcInfo-                     pid-                     (Safe.bracketWithError-                        (logDebug "enter process")-                        (\mExc () -> do-                           lift-                             (atomically-                                (do modifyTVar' processInfoVar (at pid .~ Nothing)-                                    modifyTVar' cancellationsVar (at pid .~ Nothing)))-                           traverse_ (\exc -> logExitAndTriggerLinksAndMonitors (exitReasonFromException exc) pid) mExc)-                        (const-                           (do res <- handleProcess procInfo (mfa >> return ExitNormally)-                               logExitAndTriggerLinksAndMonitors res pid)))))-           atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))-           return procAsync)-      where-        exitReasonFromException exc =-          case Safe.fromException exc of-            Just Async.AsyncCancelled -> Killed-            Nothing -> UnexpectedException (prettyCallStack callStack) (Safe.displayException exc)-        logExitAndTriggerLinksAndMonitors reason pid = do-          triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)-          logProcessExit reason-          return reason+ where+  linkToParent toProcInfo parent = do+    let toPid     = toProcInfo ^. processId+        parentPid = parent ^. processId+    lift $ atomically $ do+      modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)+      modifyTVar' (parent ^. processLinks)     (Set.insert toPid)+  allocateProcInfo schedulerState = lift+    (atomically+      (do+        let nextPidVar     = schedulerState ^. nextPid+            processInfoVar = schedulerState ^. processTable+        pid <- readTVar nextPidVar+        modifyTVar' nextPidVar (+ 1)+        procInfo <- newProcessInfo pid+        modifyTVar' processInfoVar (at pid ?~ procInfo)+        return procInfo+      )+    )+  logAppendProcInfo pid =+    let addProcessId = over+          lmProcessId+          (maybe (Just (T.pack (printf "% 9s" (show pid)))) Just)+    in  censorLogs @IO addProcessId+  triggerProcessLinksAndMonitors+    :: ProcessId -> ExitReason e -> TVar (Set ProcessId) -> Eff SchedulerIO ()+  triggerProcessLinksAndMonitors !pid !reason !linkSetVar = do+    schedulerState <- getSchedulerState+    lift $ atomically $ triggerAndRemoveMonitor pid+                                                (SomeExitReason reason)+                                                schedulerState+    let exitSeverity = toExitSeverity reason+        sendIt !linkedPid = do+          let msg = SomeExitReason (LinkedProcessCrashed pid)+          lift $ atomically $ do+            procInfoTable <- readTVar (schedulerState ^. processTable)+            let mLinkedProcInfo = procInfoTable ^? ix linkedPid+            case mLinkedProcInfo of+              Nothing -> return (Left linkedPid)+              Just linkedProcInfo ->+                let linkedMsgQVar    = linkedProcInfo ^. messageQ+                    linkedLinkSetVar = linkedProcInfo ^. processLinks+                in  do+                      linkedLinkSet <- readTVar linkedLinkSetVar+                      if Set.member pid linkedLinkSet+                        then do+                          writeTVar linkedLinkSetVar+                                    (Set.delete pid linkedLinkSet)+                          when+                            (exitSeverity == Crash)+                            (modifyTVar' linkedMsgQVar+                                         (shutdownRequests ?~ msg)+                            )+                          return (Right linkedPid)+                        else return (Left linkedPid)+    linkedPids <- lift+      (atomically+        (do+          linkSet <- readTVar linkSetVar+          writeTVar linkSetVar def+          return linkSet+        )+      )+    res <- traverse sendIt (toList linkedPids)+    traverse_+      (logDebug . either+        (("linked process no found: " <>) . T.pack . show)+        (("sent shutdown to linked process: " <>) . T.pack . show)+      )+      res+  doForkProc+    :: ProcessInfo+    -> SchedulerState+    -> Eff SchedulerIO (Async (ExitReason 'NoRecovery))+  doForkProc procInfo schedulerState = control+    (\inScheduler -> do+      let cancellationsVar = schedulerState ^. processCancellationTable+          processInfoVar   = schedulerState ^. processTable+          pid              = procInfo ^. processId+      procAsync <- Async.async+        (inScheduler+          (logAppendProcInfo+            pid+            (Safe.bracketWithError+              (logDebug "enter process")+              (\mExc () -> do+                lift+                  (atomically+                    (do+                      modifyTVar' processInfoVar   (at pid .~ Nothing)+                      modifyTVar' cancellationsVar (at pid .~ Nothing)+                    )+                  )+                traverse_+                  (\exc -> logExitAndTriggerLinksAndMonitors+                    (exitReasonFromException exc)+                    pid+                  )+                  mExc+              )+              (const+                (do+                  res <- handleProcess procInfo (mfa >> return ExitNormally)+                  logExitAndTriggerLinksAndMonitors res pid+                )+              )+            )+          )+        )+      atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))+      return procAsync+    )+   where+    exitReasonFromException exc = case Safe.fromException exc of+      Just Async.AsyncCancelled -> Killed+      Nothing -> UnexpectedException (prettyCallStack callStack)+                                     (Safe.displayException exc)+    logExitAndTriggerLinksAndMonitors reason pid = do+      triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)+      logProcessExit reason+      return reason  -- * Scheduler Accessor getSchedulerState :: HasSchedulerIO r => Eff r SchedulerState getSchedulerState = ask -enqueueMessageOtherProcess :: HasCallStack => ProcessId -> Dynamic -> SchedulerState -> STM ()+enqueueMessageOtherProcess+  :: HasCallStack => ProcessId -> Dynamic -> SchedulerState -> STM () enqueueMessageOtherProcess toPid msg schedulerState =-  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>=-  maybe+  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= maybe     (return ())     (\toProcessTable -> do-       modifyTVar' (toProcessTable ^. messageQ) (incomingMessages %~ (:|> msg))-       return ())+      modifyTVar' (toProcessTable ^. messageQ) (incomingMessages %~ (:|> msg))+      return ()+    ) -enqueueShutdownRequest :: HasCallStack => ProcessId -> SomeExitReason -> SchedulerState -> STM ()+enqueueShutdownRequest+  :: HasCallStack => ProcessId -> SomeExitReason -> SchedulerState -> STM () enqueueShutdownRequest toPid msg schedulerState =-  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>=-  maybe+  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= maybe     (return ())     (\toProcessTable -> do-       modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg)-       return ())+      modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg)+      return ()+    )

@@ -14,6 +14,8 @@ import           Control.Eff.Extend import           Control.Eff.Concurrent.Process import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.Console import           Control.Lens            hiding ( (|>)                                                 , Empty                                                 )@@ -98,7 +100,7 @@  flushMsgs :: ProcessId -> STS m r -> ([Dynamic], STS m r) flushMsgs pid = State.runState $ do-  msgs <- msgQs . at pid . _Just <<.= Empty+  msgs <- msgQs . ix pid <<.= Empty   return (toList msgs)  receiveMsg

@@ -46,167 +46,76 @@ -- -- See "Control.Eff.Log.Handler#LogPredicate" module Control.Eff.Log-  ( -- * Module Re-Exports-    -- | This module contains the API for __sending__ log messages and for-    -- handling the messages in the frame work of extensible effects.-    ---    -- It also defines the reader effect to access 'LogWriter's-    module Control.Eff.Log.Handler+  ( -- * Logging API+    -- ** Sending Log Messages+    logMsg+  , logWithSeverity+  , logWithSeverity'+  , logEmergency+  , logEmergency'+  , logAlert+  , logAlert'+  , logCritical+  , logCritical'+  , logError+  , logError'+  , logWarning+  , logWarning'+  , logNotice+  , logNotice'+  , logInfo+  , logInfo'+  , logDebug+  , logDebug'++    -- ** Log Message Pre-Filtering #LogPredicate#+    -- $LogPredicate+  , includeLogMessages+  , excludeLogMessages+  , setLogPredicate+  , modifyLogPredicate+  , askLogPredicate++    -- * Log Handling API++    -- ** Writing Logs+  , setLogWriter+  , addLogWriter+  , modifyLogWriter++    -- *** Log Message Modification+  , censorLogs+  , censorLogsM++    -- ** 'Logs' Effect Handling+  , Logs()+  , LogsTo+  , withLogging+  , withSomeLogging++    -- ** Low-Level API for Custom Extensions+    -- *** Log Message Interception+  , runLogs+  , respondToLogMessage+  , interceptLogMessages++    -- * Module Re-Exports     -- | The module that contains the 'LogMessage' and 'LogPredicate' definitions.     ---    -- The log message type corresponds to RFC-5424, including structured data.+    -- The log message type corresponds roughly to RFC-5424, including structured data.   , module Control.Eff.Log.Message-    -- | This module only exposes a 'LogWriter' for asynchronous logging;-  , module Control.Eff.Log.Channel+    -- | Rendering functions for 'LogMessage's+    --+    -- The functions have been seperated from "Control.Eff.Log.Message"+  , module Control.Eff.Log.MessageRenderer+     -- | This module defines the 'LogWriter' type, which is used to give     -- callback functions for log messages an explicit type.   , module Control.Eff.Log.Writer-  -- * Example Code for Logging-  , exampleLogging-  , exampleWithLogging-  , exampleWithSomeLogging-  , exampleLogPredicate-  , exampleLogCapture-  , exampleAsyncLogging   ) where -import           Control.Eff.Log.Channel import           Control.Eff.Log.Handler import           Control.Eff.Log.Message+import           Control.Eff.Log.MessageRenderer import           Control.Eff.Log.Writer--import           Control.Eff-import           Control.Lens (view, (%~), to)----- * Logging examples---- | Example code for:------  * 'withConsoleLogging'---  * 'ioLogWriter'---  * 'printLogMessage'---  * 'logDebug'---  * 'logError'---  * 'prefixLogMessagesWith'---  * 'addLogWriter'---  * 'debugTraceLogWriter'---  * 'setLogPredicate'---  * 'logInfo'---  * 'logMsg'---  * 'logWarning'---  * 'logCritical'---  * 'lmMessage'-exampleLogging :: IO ()-exampleLogging =-    runLift-  $ withConsoleLogging "my-app" local7 allLogMessages-  $ do-      logDebug "test 1.1"-      logError "test 1.2"-      censorLogs (prefixLogMessagesWith "NESTED: ")-       $ do-            addLogWriter debugTraceLogWriter-             $ setLogPredicate (\m -> (view lmMessage m) /= "not logged")-             $ do-                  logInfo "not logged"-                  logMsg "test 2.1"-            logWarning "test 2.2"-      logCritical "test 1.3"---- | Example code for:------  * 'withLogging'---  * 'consoleLogWriter'-exampleWithLogging :: IO ()-exampleWithLogging =-    runLift-  $ withLogging consoleLogWriter-  $ logDebug "Oh, hi there"---- | Example code for:------  * 'withSomeLogging'---  * 'PureLogWriter'---  * 'logDebug'-exampleWithSomeLogging :: ()-exampleWithSomeLogging =-    run-  $ withSomeLogging @PureLogWriter-  $ logDebug "Oh, hi there"---- | Example code for:------  * 'setLogPredicate'---  * 'modifyLogPredicate'---  * 'lmMessageStartsWith'---  * 'lmSeverityIs'---  * 'lmSeverityIsAtLeast'---  * 'includeLogMessages'---  * 'excludeLogMessages'-exampleLogPredicate :: IO Int-exampleLogPredicate =-    runLift-  $ withSomeLogging @IO-  $ setLogWriter consoleLogWriter-  $ do logMsg "test"-       setLogPredicate (lmMessageStartsWith "OMG")-                         (do logMsg "this message will not be logged"-                             logMsg "OMG logged"-                             modifyLogPredicate (\p lm -> p lm || lmSeverityIs errorSeverity lm) $ do-                               logDebug "OMG logged"-                               logInfo "Not logged"-                               logError "Logged"-                               logEmergency "Not Logged"-                               includeLogMessages (lmSeverityIsAtLeast warningSeverity) $ do-                                 logInfo "Not logged"-                                 logError "Logged"-                                 logEmergency "Logged"-                                 logWarning "Logged"-                                 logDebug "OMG still Logged"-                                 excludeLogMessages (lmMessageStartsWith "OMG") $ do-                                   logDebug "OMG NOT Logged"-                                   logError "OMG ALSO NOT Logged"-                                   logEmergency "Still Logged"-                                   logWarning "Still Logged"-                                 logWarning "Logged"-                                 logDebug "OMG still Logged"-                             return 42)---- | Example code for:------  * 'runCapturedLogsWriter'---  * 'listLogWriter'---  * 'mappingLogWriter'---  * 'filteringLogWriter'-exampleLogCapture :: IO ()-exampleLogCapture = go >>= putStrLn- where go = fmap (unlines . map renderLogMessage . snd)-              $  runLift-              $  runCapturedLogsWriter-              $  withLogging listLogWriter-              $  addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter)-              $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter))-              $  do-                    logEmergency "test emergencySeverity 1"-                    logCritical "test criticalSeverity 2"-                    logAlert "test alertSeverity 3"-                    logError "test errorSeverity 4"-                    logWarning "test warningSeverity 5"-                    logInfo "test informationalSeverity 6"-                    logDebug "test debugSeverity 7"-       severeMessages = view (lmSeverity . to (<= errorSeverity))----- | Example code for:------  * 'withAsyncLogging'-exampleAsyncLogging :: IO ()-exampleAsyncLogging =-    runLift-  $ withSomeLogging @IO-  $ withAsyncLogging (1000::Int) consoleLogWriter-  $ do logMsg "test 1"-       logMsg "test 2"-       logMsg "test 3"

@@ -1,88 +0,0 @@--- | Asynchronous Logging-module Control.Eff.Log.Channel-  ( withAsyncLogging-  ) where--import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Eff as Eff-import Control.Eff.Log.Handler-import Control.Eff.Log.Message-import Control.Eff.Log.Writer-import Control.Exception (evaluate)-import Control.Monad (unless)-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp)-import Data.Foldable (traverse_)-import Data.Kind ()---- | Fork a new process in which the given log message writer, will listen--- on a message queue, to which all log message will be relayed.------ If an exception is received, the logging process will be killed.------ Log messages are deeply evaluated before being sent to the logger process,--- to prevent that lazy evaluation leads to heavy work being done in the--- logger process instead of the caller process.------ Example:------ > exampleAsyncLogging :: IO ()--- > exampleAsyncLogging =--- >     runLift--- >   $ withSomeLogging @IO--- >   $ withAsyncLogging (1000::Int) consoleLogWriter--- >   $ do logMsg "test 1"--- >        logMsg "test 2"--- >        logMsg "test 3"--- >----withAsyncLogging ::-     ( LogsTo IO e-     , Lifted IO e-     , MonadBaseControl IO (Eff e)-     , Integral len-     )-  => len -- ^ Size of the log message input queue. If the queue is full, message-         -- are dropped silently.-  -> LogWriter IO-  -> Eff e a-  -> Eff e a-withAsyncLogging queueLength lw e =-  liftBaseOp-    (withAsyncLogChannel queueLength (runLogWriter lw . force))-    (\lc -> setLogWriter (makeLogChannelWriter lc) e)--withAsyncLogChannel ::-     forall a len. (Integral len)-  => len-  -> (LogMessage -> IO ())-  -> (LogChannel -> IO a)-  -> IO a-withAsyncLogChannel queueLen ioWriter action = do-  msgQ <- newTBQueueIO (fromIntegral queueLen)-  withAsync (logLoop msgQ) (action . ConcurrentLogChannel msgQ)-  where-    logLoop tq = do-      ms <--        atomically $ do-          h <- readTBQueue tq-          t <- flushTBQueue tq-          return (h : t)-      traverse_ ioWriter ms-      logLoop tq--makeLogChannelWriter :: LogChannel -> LogWriter IO-makeLogChannelWriter lc = ioLogWriter logChannelPutIO-  where-    logChannelPutIO (force -> me) = do-      !m <- evaluate me-      atomically-        (do dropMessage <- isFullTBQueue logQ-            unless dropMessage (writeTBQueue logQ m))-    logQ = fromLogChannel lc--data LogChannel = ConcurrentLogChannel-  { fromLogChannel :: TBQueue LogMessage-  , _logChannelThread :: Async ()-  }

@@ -0,0 +1,240 @@+-- | Examples for Logging.+module Control.Eff.Log.Examples+  ( -- * Example Code for Logging+    exampleLogging+  , exampleWithLogging+  , exampleWithSomeLogging+  , exampleLogPredicate+  , exampleLogCapture+  , exampleAsyncLogging+  , exampleRFC5424Logging+  , exampleRFC3164WithRFC5424TimestampsLogging+  , exampleDevLogSyslogLogging+  , exampleDevLogRFC5424Logging+  , exampleUdpRFC5424Logging+  , exampleUdpRFC3164Logging+  -- * Example Client Code+  , loggingExampleClient+  , logPredicatesExampleClient+  )+where++import           Control.Eff.Log+import           Control.Eff.LogWriter.Async+import           Control.Eff.LogWriter.Console+import           Control.Eff.LogWriter.DebugTrace+import           Control.Eff.LogWriter.Capture+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.UnixSocket+import           Control.Eff.LogWriter.UDP+import           Control.Eff+import           Control.Lens                   ( view+                                                , (%~)+                                                , to+                                                )+import           Data.Text                     as T+import           Data.Text.IO                  as T+import           GHC.Stack++-- * Logging examples++-- | Example code for:+--+--  * 'withConsoleLogging'+--  * 'mkLogWriterIO'+-- See 'loggingExampleClient'+exampleLogging :: HasCallStack => IO ()+exampleLogging = runLift+  $ withConsoleLogging "my-app" local7 allLogMessages loggingExampleClient++-- | Example code for:+--+--  * 'withLogging'+--  * 'consoleLogWriter'+exampleWithLogging :: HasCallStack => IO ()+exampleWithLogging =+  runLift $ withLogging consoleLogWriter $ logDebug "Oh, hi there"++-- | Example code for:+--+--  * 'withSomeLogging'+--  * 'PureLogWriter'+--  * 'logDebug'+exampleWithSomeLogging :: HasCallStack => ()+exampleWithSomeLogging =+  run $ withSomeLogging @PureLogWriter $ logDebug "Oh, hi there"++-- | Example code for:+--+--  * 'setLogPredicate'+--  * 'modifyLogPredicate'+--  * 'lmMessageStartsWith'+--  * 'lmSeverityIs'+--  * 'lmSeverityIsAtLeast'+--  * 'includeLogMessages'+--  * 'excludeLogMessages'+exampleLogPredicate :: HasCallStack => IO Int+exampleLogPredicate =+  runLift+    $ withSomeLogging @IO+    $ setLogWriter consoleLogWriter+    $ logPredicatesExampleClient++-- | Example code for:+--+--  * 'runCaptureLogWriter'+--  * 'captureLogWriter'+--  * 'mappingLogWriter'+--  * 'filteringLogWriter'+exampleLogCapture :: IO ()+exampleLogCapture = go >>= T.putStrLn+ where+  go =+    fmap (T.unlines . Prelude.map renderLogMessageConsoleLog . snd)+      $ runLift+      $ runCaptureLogWriter+      $ withLogging captureLogWriter+      $ addLogWriter+          (mappingLogWriter (lmMessage %~ ("CAPTURED " <>)) captureLogWriter)+      $ addLogWriter+          (filteringLogWriter+            severeMessages+            (mappingLogWriter (lmMessage %~ ("TRACED " <>))+                              (debugTraceLogWriter renderRFC5424)+            )+          )+      $ do+          logEmergency "test emergencySeverity 1"+          logCritical "test criticalSeverity 2"+          logAlert "test alertSeverity 3"+          logError "test errorSeverity 4"+          logWarning "test warningSeverity 5"+          logInfo "test informationalSeverity 6"+          logDebug "test debugSeverity 7"+  severeMessages = view (lmSeverity . to (<= errorSeverity))+++-- | Example code for:+--+--  * 'withAsyncLogging'+exampleAsyncLogging :: IO ()+exampleAsyncLogging =+  runLift $ withLogging consoleLogWriter $ withAsyncLogWriter (1000 :: Int) $ do+    logInfo "test 1"+    logInfo "test 2"+    logInfo "test 3"+++-- | Example code for RFC5424 formatted logs.+exampleRFC5424Logging :: IO Int+exampleRFC5424Logging =+  runLift+    $ withSomeLogging @IO+    $ setLogWriter+        (defaultIoLogWriter "myapp" local2 (debugTraceLogWriter renderRFC5424))+    $ logPredicatesExampleClient++-- | Example code for RFC3164 with RFC5424 time stamp formatted logs.+exampleRFC3164WithRFC5424TimestampsLogging :: IO Int+exampleRFC3164WithRFC5424TimestampsLogging =+  runLift+    $ withSomeLogging @IO+    $ setLogWriter+        (defaultIoLogWriter "myapp" local2 (debugTraceLogWriter renderRFC3164WithRFC5424Timestamps))+    $ logPredicatesExampleClient++-- | Example code logging via a unix domain socket to @/dev/log@.+exampleDevLogSyslogLogging :: IO Int+exampleDevLogSyslogLogging =+  runLift+    $ withUnixSocketLogging renderLogMessageSyslog "/dev/log" "myapp" local2 allLogMessages+      logPredicatesExampleClient+++-- | Example code logging via a unix domain socket to @/dev/log@.+exampleDevLogRFC5424Logging :: IO Int+exampleDevLogRFC5424Logging =+  runLift+    $ withUnixSocketLogging renderRFC5424 "/dev/log" "myapp" local2 allLogMessages+      logPredicatesExampleClient+++-- | Example code logging RFC5424 via UDP port 514 on localhost.+exampleUdpRFC5424Logging :: IO Int+exampleUdpRFC5424Logging =+  runLift+    $ withUDPLogging renderRFC5424 "localhost" "514"  "myapp" local2 allLogMessages+      logPredicatesExampleClient++-- | Example code logging RFC5424 via UDP port 514 on localhost.+exampleUdpRFC3164Logging :: IO Int+exampleUdpRFC3164Logging =+  runLift+    $ withUDPLogging renderRFC3164 "localhost" "514"  "myapp" local1 allLogMessages+      logPredicatesExampleClient++-- | Example logging client code+--+--  * 'addLogWriter'+--  * 'debugTraceLogWriter'+--  * 'setLogPredicate'+--  * 'prefixLogMessagesWith'+--  * 'renderRFC3164'+--  * 'logMsg'+--  * 'logDebug'+--  * 'logError'+--  * 'logInfo'+--  * 'logWarning'+--  * 'logCritical'+--  * 'lmMessage'+loggingExampleClient :: (HasCallStack, Monad h, LogsTo h e) => Eff e ()+loggingExampleClient = do+  logDebug "test 1.1"+  logError "test 1.2"+  censorLogs (prefixLogMessagesWith "NESTED: ") $ do+    addLogWriter (debugTraceLogWriter renderRFC3164)+      $ setLogPredicate (\m -> view lmMessage m /= "not logged")+      $ do+          logInfo "not logged"+          logMsg "test 2.1"+    logWarning "test 2.2"+  logCritical "test 1.3"+++-- | Example logging client code using many 'LogPredicate's.+--+--  * 'setLogPredicate'+--  * 'modifyLogPredicate'+--  * 'lmMessageStartsWith'+--  * 'lmSeverityIs'+--  * 'lmSeverityIsAtLeast'+--  * 'includeLogMessages'+--  * 'excludeLogMessages'+logPredicatesExampleClient :: (HasCallStack, Monad h, LogsTo h e) => Eff e Int+logPredicatesExampleClient = do+  logInfo "test"+  setLogPredicate+    (lmMessageStartsWith "OMG")+    (do+      logInfo "this message will not be logged"+      logInfo "OMG logged"+      modifyLogPredicate (\p lm -> p lm || lmSeverityIs errorSeverity lm) $ do+        logDebug "OMG logged"+        logInfo "Not logged"+        logError "Logged"+        logEmergency "Not Logged"+        includeLogMessages (lmSeverityIsAtLeast warningSeverity) $ do+          logInfo "Not logged"+          logError "Logged"+          logEmergency "Logged"+          logWarning "Logged"+          logDebug "OMG still Logged"+          excludeLogMessages (lmMessageStartsWith "OMG") $ do+            logDebug "OMG NOT Logged"+            logError "OMG ALSO NOT Logged"+            logEmergency "Still Logged"+            logWarning "Still Logged"+          logWarning "Logged"+          logDebug "OMG still Logged"+      return 42+    )

@@ -9,14 +9,23 @@     -- ** Sending Log Messages     logMsg   , logWithSeverity+  , logWithSeverity'   , logEmergency+  , logEmergency'   , logAlert+  , logAlert'   , logCritical+  , logCritical'   , logError+  , logError'   , logWarning+  , logWarning'   , logNotice+  , logNotice'   , logInfo+  , logInfo'   , logDebug+  , logDebug'    -- ** Log Message Pre-Filtering #LogPredicate#   -- $LogPredicate@@ -34,18 +43,15 @@   , modifyLogWriter    -- *** Log Message Modification-  , withLogFileAppender   , censorLogs   , censorLogsM    -- ** 'Logs' Effect Handling   , Logs()   , LogsTo-  , withConsoleLogging-  , withIoLogging   , withLogging   , withSomeLogging-  , LoggingAndIo+   -- ** Low-Level API for Custom Extensions   -- *** Log Message Interception   , runLogs@@ -70,21 +76,17 @@                                                    , liftBaseWith                                                    , StM                                                    )-                                                   , liftBaseOp                                                  ) import           Data.Default import           Data.Function                  ( fix )+import           Data.Text                     as T import           GHC.Stack                      ( HasCallStack                                                 , callStack                                                 , withFrozenCallStack                                                 )-import qualified System.IO                     as IO-import           System.Directory               ( canonicalizePath-                                                , createDirectoryIfMissing-                                                )-import           System.FilePath                ( takeDirectory )  + -- | This effect sends 'LogMessage's and is a reader for a 'LogPredicate'. -- -- Logs are sent via 'logMsg';@@ -171,61 +173,12 @@ -- -- The requirements of this constraint are provided by: ----- * 'withConsoleLogging' -- * 'withIoLogging' -- * 'withLogging' -- * 'withSomeLogging' -- type LogsTo h e = (Member Logs e, HandleLogWriter h, LogWriterEffects h <:: e, SetMember LogWriterReader (LogWriterReader h) e) --- | Enable logging to @standard output@ using the 'defaultIoLogWriter' in combination with--- the 'consoleLogWriter'.------ Example:------ > exampleWithConsoleLogging :: IO ()--- > exampleWithConsoleLogging =--- >     runLift--- >   $ withConsoleLogging "my-app" local7 allLogMessages--- >   $ logInfo "Oh, hi there"------ To vary the 'LogWriter' use 'withIoLogging'.-withConsoleLogging-  :: SetMember Lift (Lift IO) e-  => String -- ^ The default application name to put into the 'lmAppName' field.-  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.-  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"-  -> Eff (Logs : LogWriterReader IO : e) a-  -> Eff e a-withConsoleLogging = withIoLogging consoleLogWriter---- | Enable logging to IO using the 'defaultIoLogWriter'.------ To log to the console (standard output), one can use 'withConsoleLogging'.------ Example:------ > exampleWithIoLogging :: IO ()--- > exampleWithIoLogging =--- >     runLift--- >   $ withIoLogging consoleLogWriter--- >                   "my-app"--- >                   local7--- >                   (lmSeverityIsAtLeast informationalSeverity)--- >   $ logInfo "Oh, hi there"----withIoLogging-  :: SetMember Lift (Lift IO) e-  => LogWriter IO -- ^ The 'LogWriter' that will be used to write log messages.-  -> String -- ^ The default application name to put into the 'lmAppName' field.-  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.-  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"-  -> Eff (Logs : LogWriterReader IO : e) a-  -> Eff e a-withIoLogging lw appName facility defaultPredicate =-    withLogging (defaultIoLogWriter appName facility lw)-  . setLogPredicate defaultPredicate- -- | Handle the 'Logs' and 'LogWriterReader' effects. -- -- It installs the given 'LogWriter', which determines the underlying@@ -266,9 +219,6 @@   -> Eff e a withSomeLogging = withLogging (noOpLogWriter @h) --- | The concrete list of 'Eff'ects for logging with an IO based 'LogWriter', and a 'LogWriterReader'.-type LoggingAndIo = '[Logs, LogWriterReader IO, Lift IO]- -- | Raw handling of the 'Logs' effect. -- Exposed for custom extensions, if in doubt use 'withLogging'. runLogs@@ -287,36 +237,50 @@ -- This function is the only place where the 'LogPredicate' is applied. -- -- Also, 'LogMessage's are evaluated using 'deepseq', __after__ they pass the 'LogPredicate'.-logMsg :: forall e m . (HasCallStack, Member Logs e, ToLogMessage m) => m -> Eff e ()-logMsg (toLogMessage -> msgIn) =-  withFrozenCallStack $ do+logMsg :: forall e . (HasCallStack, Member Logs e) => LogMessage -> Eff e ()+logMsg = withFrozenCallStack $ \msgIn -> do     lf <- askLogPredicate     when (lf msgIn) $       msgIn `deepseq` send @Logs (WriteLogMessage msgIn) --- | Log a 'String' as 'LogMessage' with a given 'Severity'.+-- | Log a 'T.Text' as 'LogMessage' with a given 'Severity'. logWithSeverity   :: forall e .      ( HasCallStack      , Member Logs e      )   => Severity-  -> String+  -> Text   -> Eff e ()-logWithSeverity !s =-  withFrozenCallStack-    $ logMsg+logWithSeverity = withFrozenCallStack $ \s ->+    logMsg     . setCallStack callStack     . set lmSeverity s     . flip (set lmMessage) def +-- | Log a 'T.Text' as 'LogMessage' with a given 'Severity'.+logWithSeverity'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => Severity+  -> String+  -> Eff e ()+logWithSeverity' = withFrozenCallStack+  (\s m ->+       logMsg+     $ setCallStack callStack+     $ set lmSeverity s+     $ ( def & lmMessage .~ T.pack m))+ -- | Log a 'String' as 'emergencySeverity'. logEmergency   :: forall e .      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity) @@ -326,7 +290,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logAlert = withFrozenCallStack (logWithSeverity alertSeverity) @@ -336,7 +300,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logCritical = withFrozenCallStack (logWithSeverity criticalSeverity) @@ -346,7 +310,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logError = withFrozenCallStack (logWithSeverity errorSeverity) @@ -356,7 +320,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logWarning = withFrozenCallStack (logWithSeverity warningSeverity) @@ -366,7 +330,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logNotice = withFrozenCallStack (logWithSeverity noticeSeverity) @@ -376,7 +340,7 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logInfo = withFrozenCallStack (logWithSeverity informationalSeverity) @@ -386,10 +350,90 @@      ( HasCallStack      , Member Logs e      )-  => String+  => Text   -> Eff e () logDebug = withFrozenCallStack (logWithSeverity debugSeverity) +-- | Log a 'String' as 'emergencySeverity'.+logEmergency'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logEmergency' = withFrozenCallStack (logWithSeverity' emergencySeverity)++-- | Log a message with 'alertSeverity'.+logAlert'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logAlert' = withFrozenCallStack (logWithSeverity' alertSeverity)++-- | Log a 'criticalSeverity' message.+logCritical'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logCritical' = withFrozenCallStack (logWithSeverity' criticalSeverity)++-- | Log a 'errorSeverity' message.+logError'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logError' = withFrozenCallStack (logWithSeverity' errorSeverity)++-- | Log a 'warningSeverity' message.+logWarning'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logWarning' = withFrozenCallStack (logWithSeverity' warningSeverity)++-- | Log a 'noticeSeverity' message.+logNotice'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logNotice' = withFrozenCallStack (logWithSeverity' noticeSeverity)++-- | Log a 'informationalSeverity' message.+logInfo'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logInfo' = withFrozenCallStack (logWithSeverity' informationalSeverity)++-- | Log a 'debugSeverity' message.+logDebug'+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logDebug' = withFrozenCallStack (logWithSeverity' debugSeverity)+ -- $LogPredicate -- -- Ways to change the 'LogPredicate' are:@@ -587,14 +631,16 @@  -- | Combine the effects of a given 'LogWriter' and the existing one. --+-- > import Data.Text    as T+-- > import Data.Text.IO as T -- > -- > exampleAddLogWriter :: IO ()--- > exampleAddLogWriter = go >>= putStrLn--- >  where go = fmap (unlines . map renderLogMessage . snd)+-- > exampleAddLogWriter = go >>= T.putStrLn+-- >  where go = fmap (unlines . map renderLogMessageConsoleLog . snd) -- >               $  runLift--- >               $  runCapturedLogsWriter--- >               $  withLogging listLogWriter--- >               $  addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter)+-- >               $  runCaptureLogWriter+-- >               $  withLogging captureLogWriter+-- >               $  addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) captureLogWriter) -- >               $  addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter)) -- >               $  do -- >                     logEmergency "test emergencySeverity 1"@@ -611,30 +657,3 @@      (HasCallStack, LogsTo h e, Monad h)   => LogWriter h -> Eff e a -> Eff e a addLogWriter lw2 = modifyLogWriter (\lw1 -> MkLogWriter (\m -> runLogWriter lw1 m >> runLogWriter lw2 m))---- | Open a file and add the 'LogWriter' in the 'LogWriterReader' tha appends the log messages to it.-withLogFileAppender-  :: ( Lifted IO e-     , LogsTo IO e-     , MonadBaseControl IO (Eff e)-     )-  => FilePath-  -> Eff e b-  -> Eff e b-withLogFileAppender fnIn e = liftBaseOp withOpenedLogFile (`addLogWriter` e)-  where-    withOpenedLogFile-      :: HasCallStack-      => (LogWriter IO -> IO a)-      -> IO a-    withOpenedLogFile ioE =-      Safe.bracket-          (do-            fnCanon <- canonicalizePath fnIn-            createDirectoryIfMissing True (takeDirectory fnCanon)-            h <- IO.openFile fnCanon IO.AppendMode-            IO.hSetBuffering h (IO.BlockBuffering (Just 1024))-            return h-          )-          (\h -> Safe.try @IO @Catch.SomeException (IO.hFlush h) >> IO.hClose h)-          (\h -> ioE (ioHandleLogWriter h))

@@ -1,3 +1,4 @@+{-# LANGUAGE QuantifiedConstraints #-} -- | An RFC 5434 inspired log message and convenience functions for -- logging them. module Control.Eff.Log.Message@@ -23,11 +24,6 @@   , setLogMessageThreadId   , setLogMessageHostname -  -- ** Log Message Text Rendering-  , renderRFC5424-  , printLogMessage-  , renderLogMessage-   -- ** Log Message Construction   , errorMessage   , infoMessage@@ -54,8 +50,6 @@   -- ** RFC-5424 Structured Data   , StructuredDataElement(..)   , SdParameter(..)-  , sdName-  , sdParamValue   , sdElementId   , sdElementParameters @@ -71,7 +65,7 @@   , debugSeverity    -- * RFC 5424 Facility-  , Facility(fromFacility)+  , Facility (..)   -- ** Facility Constructors   , kernelMessages   , userLevelMessages@@ -106,66 +100,49 @@ import           Control.Monad.IO.Class import           Data.Default import           Data.Maybe-import           Data.String+import           Data.String                    (IsString(..))+import qualified Data.Text                     as T import           Data.Time.Clock-import           Data.Time.Format-import           GHC.Generics                   hiding (to)+import           GHC.Generics            hiding ( to ) import           GHC.Stack-import           Network.HostName               as Network-import           System.FilePath.Posix-import           Text.Printf+import           Network.HostName              as Network  -- | A message data type inspired by the RFC-5424 Syslog Protocol data LogMessage =   MkLogMessage { _lmFacility :: !Facility                , _lmSeverity :: !Severity-               , _lmTimestamp :: !(Maybe UTCTime)-               , _lmHostname :: !(Maybe String)-               , _lmAppName :: !(Maybe String)-               , _lmProcessId :: !(Maybe String)-               , _lmMessageId :: !(Maybe String)-               , _lmStructuredData :: ![StructuredDataElement]-               , _lmThreadId :: !(Maybe ThreadId)-               , _lmSrcLoc :: !(Maybe SrcLoc)-               , _lmMessage :: !String}+               , _lmTimestamp :: (Maybe UTCTime)+               , _lmHostname :: (Maybe T.Text)+               , _lmAppName :: (Maybe T.Text)+               , _lmProcessId :: (Maybe T.Text)+               , _lmMessageId :: (Maybe T.Text)+               , _lmStructuredData :: [StructuredDataElement]+               , _lmThreadId :: (Maybe ThreadId)+               , _lmSrcLoc :: (Maybe SrcLoc)+               , _lmMessage :: T.Text}   deriving (Eq, Generic)  instance Default LogMessage where   def = MkLogMessage def def def def def def def def def def "" +-- | This instance is __only__ supposed to be used for unit tests and debugging.+instance Show LogMessage where+  show = T.unpack . _lmMessage+ instance NFData LogMessage  -- | RFC-5424 defines how structured data can be included in a log message. data StructuredDataElement =-  SdElement { _sdElementId :: !String+  SdElement { _sdElementId :: !T.Text             , _sdElementParameters :: ![SdParameter]}-  deriving (Eq, Ord, Generic)--instance Show StructuredDataElement where-  show (SdElement sdId params) =-    "[" ++ sdName sdId ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]"+  deriving (Eq, Ord, Generic, Show)  instance NFData StructuredDataElement  -- | Component of an RFC-5424 'StructuredDataElement' data SdParameter =-  MkSdParameter !String !String-  deriving (Eq, Ord, Generic)--instance Show SdParameter where-  show (MkSdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\""---- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424.-sdName :: String -> String-sdName = take 32 . filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')---- | Extract the value of an 'SdParameter'.-sdParamValue :: String -> String-sdParamValue e = e >>= \case-  '"'  -> "\\\""-  '\\' -> "\\\\"-  ']'  -> "\\]"-  x    -> [x]+  MkSdParameter !T.Text !T.Text+  deriving (Eq, Ord, Generic, Show)  instance NFData SdParameter @@ -175,13 +152,13 @@   deriving (Eq, Ord, Generic, NFData)  instance Show Severity where-  show (Severity 1)             = "ALERT    "-  show (Severity 2)             = "CRITICAL "-  show (Severity 3)             = "ERROR    "-  show (Severity 4)             = "WARNING  "-  show (Severity 5)             = "NOTICE   "-  show (Severity 6)             = "INFO     "-  show (Severity x) |  x <= 0   = "EMERGENCY"+  show (Severity 1) = "ALERT    "+  show (Severity 2) = "CRITICAL "+  show (Severity 3) = "ERROR    "+  show (Severity 4) = "WARNING  "+  show (Severity 5) = "NOTICE   "+  show (Severity 6) = "INFO     "+  show (Severity x) | x <= 0    = "EMERGENCY"                     | otherwise = "DEBUG    " --  *** Severities @@ -362,60 +339,83 @@ makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement  -- | A lens for 'SdParameter's-sdElementParameters :: Functor f =>-                             ([SdParameter] -> f [SdParameter])-                             -> StructuredDataElement -> f StructuredDataElement+sdElementParameters+  :: Functor f+  => ([SdParameter] -> f [SdParameter])+  -> StructuredDataElement+  -> f StructuredDataElement  -- | A lens for the key or ID of a group of RFC 5424 key-value pairs.-sdElementId :: Functor f =>-                     (String -> f String)-                     -> StructuredDataElement -> f StructuredDataElement+sdElementId+  :: Functor f+  => (T.Text -> f T.Text)+  -> StructuredDataElement+  -> f StructuredDataElement  makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage  -- | A lens for the UTC time of a 'LogMessage' -- The function 'setLogMessageTimestamp' can be used to set the field.-lmTimestamp :: Functor f =>-               (Maybe UTCTime -> f (Maybe UTCTime)) -> LogMessage -> f LogMessage+lmTimestamp+  :: Functor f+  => (Maybe UTCTime -> f (Maybe UTCTime))+  -> LogMessage+  -> f LogMessage  -- | A lens for the 'ThreadId' of a 'LogMessage' -- The function 'setLogMessageThreadId' can be used to set the field.-lmThreadId :: Functor f =>-              (Maybe ThreadId -> f (Maybe ThreadId)) -> LogMessage -> f LogMessage+lmThreadId+  :: Functor f+  => (Maybe ThreadId -> f (Maybe ThreadId))+  -> LogMessage+  -> f LogMessage  -- | A lens for the 'StructuredDataElement' of a 'LogMessage'-lmStructuredData :: Functor f =>-                    ([StructuredDataElement] -> f [StructuredDataElement])-                    -> LogMessage -> f LogMessage+lmStructuredData+  :: Functor f+  => ([StructuredDataElement] -> f [StructuredDataElement])+  -> LogMessage+  -> f LogMessage  -- | A lens for the 'SrcLoc' of a 'LogMessage'-lmSrcLoc :: Functor f =>-            (Maybe SrcLoc -> f (Maybe SrcLoc)) -> LogMessage -> f LogMessage+lmSrcLoc+  :: Functor f+  => (Maybe SrcLoc -> f (Maybe SrcLoc))+  -> LogMessage+  -> f LogMessage  -- | A lens for the 'Severity' of a 'LogMessage'-lmSeverity :: Functor f =>-              (Severity -> f Severity) -> LogMessage -> f LogMessage+lmSeverity+  :: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage  -- | A lens for a user defined of /process/ id of a 'LogMessage'-lmProcessId :: Functor f =>-               (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage+lmProcessId+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage  -- | A lens for a user defined /message id/ of a 'LogMessage'-lmMessageId :: Functor f =>-               (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage+lmMessageId+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage  -- | A lens for the user defined textual message of a 'LogMessage'-lmMessage :: Functor f =>-             (String -> f String) -> LogMessage -> f LogMessage+lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage  -- | A lens for the hostname of a 'LogMessage' -- The function 'setLogMessageHostname' can be used to set the field.-lmHostname :: Functor f =>-              (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage+lmHostname+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage  -- | A lens for the 'Facility' of a 'LogMessage'-lmFacility :: Functor f =>-              (Facility -> f Facility) -> LogMessage -> f LogMessage+lmFacility+  :: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage  -- | A lens for the RFC 5424 /application/ name of a 'LogMessage' --@@ -427,69 +427,11 @@ -- >   view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm -- -- This concept is also implemented in 'discriminateByAppName'.-lmAppName :: Functor f =>-             (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage--instance Show LogMessage where-  show = unlines . showLmMessage---- | Print a 'LogMessage' in a very incomplete way, use only for tests and debugging-showLmMessage :: LogMessage -> [String]-showLmMessage (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =-  if null msg-    then []-    else-      maybe "" (printf "[%s]" . show) ti-      : (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.-renderLogMessage :: LogMessage -> String-renderLogMessage l@(MkLogMessage _f s ts hn an pid mi sd _ _ _) =-  unwords $ filter-    (not . null)-    ( maybe-        ""-        (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))-        ts-    : fromMaybe "" hn-    : show s-    : fromMaybe "" an-    : fromMaybe "" pid-    : fromMaybe "" mi-    : (if null sd then "" else show sd)-    : showLmMessage l-    )---- | Render a 'LogMessage' according to the rules in the given RFC, except for--- the rules concerning unicode and ascii-renderRFC5424 :: LogMessage -> String-renderRFC5424 l@(MkLogMessage f s ts hn an pid mi sd _ _ _) = unwords-  ( ("<" ++ show (fromSeverity s + fromFacility f * 8) ++ ">" ++ "1")-  : maybe-      "-"-      (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))-      ts-  : fromMaybe "-" hn-  : fromMaybe "-" an-  : fromMaybe "-" pid-  : fromMaybe "-" mi-  : (if null sd then "-" else show sd)-  : showLmMessage l-  )---- | Render a 'LogMessage' but set the timestamp and thread id fields.-printLogMessage :: LogMessage -> IO ()-printLogMessage = putStrLn . renderLogMessage+lmAppName+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage  -- | Put the source location of the given callstack in 'lmSrcLoc' setCallStack :: CallStack -> LogMessage -> LogMessage@@ -498,7 +440,7 @@   (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc  -- | Prefix the 'lmMessage'.-prefixLogMessagesWith :: String -> LogMessage -> LogMessage+prefixLogMessagesWith :: T.Text -> LogMessage -> LogMessage prefixLogMessagesWith = over lmMessage . (<>)  -- | An IO action that sets the current UTC time in 'lmTimestamp'.@@ -520,19 +462,19 @@  -- | An IO action that sets the current hosts fully qualified hostname in 'lmHostname'. setLogMessageHostname :: LogMessage -> IO LogMessage-setLogMessageHostname m = if isNothing (m ^. lmTimestamp)+setLogMessageHostname m = if isNothing (m ^. lmHostname)   then do     fqdn <- Network.getHostName-    return (m & lmHostname ?~ fqdn)+    return (m & lmHostname ?~ T.pack fqdn)   else return m  -- | Construct a 'LogMessage' with 'errorSeverity'-errorMessage :: HasCallStack => String -> LogMessage+errorMessage :: HasCallStack => T.Text -> LogMessage errorMessage m = withFrozenCallStack   (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)  -- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessage :: HasCallStack => String -> LogMessage+infoMessage :: HasCallStack => T.Text -> LogMessage infoMessage m = withFrozenCallStack   (  def   &  lmSeverity@@ -543,26 +485,26 @@   )  -- | Construct a 'LogMessage' with 'debugSeverity'-debugMessage :: HasCallStack => String -> LogMessage+debugMessage :: HasCallStack => T.Text -> LogMessage debugMessage m = withFrozenCallStack   (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)  -- | Construct a 'LogMessage' with 'errorSeverity'-errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+errorMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage errorMessageIO =   withFrozenCallStack     $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)     . errorMessage  -- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+infoMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage infoMessageIO =   withFrozenCallStack     $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)     . infoMessage  -- | Construct a 'LogMessage' with 'debugSeverity'-debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+debugMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage debugMessageIO =   withFrozenCallStack     $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)@@ -576,11 +518,11 @@ instance ToLogMessage LogMessage where   toLogMessage = id -instance ToLogMessage String where+instance ToLogMessage T.Text where   toLogMessage = infoMessage  instance IsString LogMessage where-  fromString = infoMessage+  fromString = infoMessage . T.pack  -- $PredefinedPredicates -- == Log Message Predicates@@ -632,11 +574,10 @@ -- | Match 'LogMessage's whose 'lmMessage' starts with the given string. -- -- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-lmMessageStartsWith :: String -> LogPredicate-lmMessageStartsWith prefix lm =-  case length prefix of-    0         -> True-    prefixLen -> take prefixLen (lm ^. lmMessage) == prefix+lmMessageStartsWith :: T.Text -> LogPredicate+lmMessageStartsWith prefix lm = case T.length prefix of+  0         -> True+  prefixLen -> T.take prefixLen (lm ^. lmMessage) == prefix  -- | Apply a 'LogPredicate' based on the 'lmAppName' and delegate -- to one of two 'LogPredicate's.@@ -647,8 +588,8 @@ -- from third party libraries. -- -- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-discriminateByAppName :: String -> LogPredicate -> LogPredicate -> LogPredicate+discriminateByAppName :: T.Text -> LogPredicate -> LogPredicate -> LogPredicate discriminateByAppName appName appPredicate otherPredicate lm =-   if view lmAppName lm == Just appName-      then appPredicate lm-      else otherPredicate lm+  if view lmAppName lm == Just appName+    then appPredicate lm+    else otherPredicate lm

@@ -0,0 +1,224 @@+{-# LANGUAGE QuantifiedConstraints #-}+-- | Rendering functions for 'LogMessage's.+module Control.Eff.Log.MessageRenderer+  (++  -- * Log Message Text Rendering+    LogMessageRenderer+  , renderLogMessageSyslog+  , renderLogMessageConsoleLog+  , renderRFC3164+  , renderRFC3164WithRFC5424Timestamps+  , renderRFC3164WithTimestamp+  , renderRFC5424+++  -- ** Partial Log Message Text Rendering+  , renderSyslogSeverityAndFacility+  , renderLogMessageSrcLoc+  , renderMaybeLogMessageLens+  , renderLogMessageBody+  , renderLogMessageBodyFixWidth++  -- ** Timestamp Rendering+  , LogMessageTimeRenderer()+  , mkLogMessageTimeRenderer+  , suppressTimestamp+  , rfc3164Timestamp+  , rfc5424Timestamp+  , rfc5424NoZTimestamp+  )+where++import           Control.Eff.Log.Message+import           Control.Lens+import           Data.Maybe+import qualified Data.Text                     as T+import           Data.Time.Clock+import           Data.Time.Format+import           GHC.Stack+import           System.FilePath.Posix+import           Text.Printf+++-- | 'LogMessage' rendering function+type LogMessageRenderer a = LogMessage -> a++-- | A rendering function for the 'lmTimestamp' field.+newtype LogMessageTimeRenderer =+  MkLogMessageTimeRenderer { renderLogMessageTime :: UTCTime -> T.Text }++-- | Make a  'LogMessageTimeRenderer' using 'formatTime' in the 'defaultLocale'.+mkLogMessageTimeRenderer+  :: String -- ^ The format string that is passed to 'formatTime'+  -> LogMessageTimeRenderer+mkLogMessageTimeRenderer s =+  MkLogMessageTimeRenderer (T.pack . formatTime defaultTimeLocale s)++-- | Don't render the time stamp+suppressTimestamp :: LogMessageTimeRenderer+suppressTimestamp = MkLogMessageTimeRenderer (const "")++-- | Render the time stamp using @"%h %d %H:%M:%S"@+rfc3164Timestamp :: LogMessageTimeRenderer+rfc3164Timestamp = mkLogMessageTimeRenderer "%h %d %H:%M:%S"++-- | Render the time stamp to @'iso8601DateFormat' (Just "%H:%M:%S%6QZ")@+rfc5424Timestamp :: LogMessageTimeRenderer+rfc5424Timestamp =+  mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6QZ"))++-- | Render the time stamp like 'rfc5424Timestamp' does, but omit the terminal @Z@ character.+rfc5424NoZTimestamp :: LogMessageTimeRenderer+rfc5424NoZTimestamp =+  mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6Q"))++-- | Print the thread id, the message and the source file location, seperated by simple white space.+renderLogMessageBody :: LogMessageRenderer T.Text+renderLogMessageBody = T.unwords . filter (not . T.null) <$> sequence+  [ renderShowMaybeLogMessageLens "" lmThreadId+  , view lmMessage+  , fromMaybe "" <$> renderLogMessageSrcLoc+  ]++-- | Print the /body/ of a 'LogMessage' with fix size fields (60) for the message itself+-- and 30 characters for the location+renderLogMessageBodyFixWidth :: LogMessageRenderer T.Text+renderLogMessageBodyFixWidth l@(MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti _ msg)+  = T.unwords $ filter+    (not . T.null)+    [ maybe "" ((<> " ") . T.pack . show) ti+    , msg <> T.replicate (max 0 (60 - T.length msg)) " "+    , fromMaybe "" (renderLogMessageSrcLoc l)+    ]++-- | Render a field of a 'LogMessage' using the corresponsing lens.+renderMaybeLogMessageLens+  :: T.Text -> Getter LogMessage (Maybe T.Text) -> LogMessageRenderer T.Text+renderMaybeLogMessageLens x l = fromMaybe x . view l++-- | Render a field of a 'LogMessage' using the corresponsing lens.+renderShowMaybeLogMessageLens+  :: Show a+  => T.Text+  -> Getter LogMessage (Maybe a)+  -> LogMessageRenderer T.Text+renderShowMaybeLogMessageLens x l =+  renderMaybeLogMessageLens x (l . to (fmap (T.pack . show)))++-- | Render the source location as: @at filepath:linenumber@.+renderLogMessageSrcLoc :: LogMessageRenderer (Maybe T.Text)+renderLogMessageSrcLoc = view+  ( lmSrcLoc+  . (to+      (fmap+        (\sl -> T.pack $ printf "at %s:%i"+                                (takeFileName (srcLocFile sl))+                                (srcLocStartLine sl)+        )+      )+    )+  )+++-- | Render the severity and facility as described in RFC-3164+--+-- Render e.g. as @\<192\>@.+--+-- Useful as header for syslog compatible log output.+renderSyslogSeverityAndFacility :: LogMessageRenderer T.Text+renderSyslogSeverityAndFacility (MkLogMessage !f !s _ _ _ _ _ _ _ _ _) =+  "<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">"++-- | Render the 'LogMessage' to contain the severity, message, message-id, pid.+--+-- Omit hostname, PID and timestamp.+--+-- Render the header using 'renderSyslogSeverity'+--+-- Useful for logging to @/dev/log@+renderLogMessageSyslog :: LogMessageRenderer T.Text+renderLogMessageSyslog l@(MkLogMessage _ _ _ _ an _ mi _ _ _ _)+  = renderSyslogSeverityAndFacility l <> (T.unwords+    . filter (not . T.null)+    $ [ fromMaybe "" an+      , fromMaybe "" mi+      , renderLogMessageBody l+      ])++-- | Render a 'LogMessage' human readable, for console logging+renderLogMessageConsoleLog :: LogMessageRenderer T.Text+renderLogMessageConsoleLog l@(MkLogMessage _ _ ts _ _ _ _ sd _ _ _) =+  T.unwords $ filter+    (not . T.null)+    [ view (lmSeverity . to (T.pack . show)) l+    , maybe "" (renderLogMessageTime rfc5424Timestamp) ts+    , renderLogMessageBodyFixWidth l+    , if null sd then "" else T.concat (renderSdElement <$> sd)+    ]++-- | Render a 'LogMessage' according to the rules in the RFC-3164.+renderRFC3164 :: LogMessageRenderer T.Text+renderRFC3164 = renderRFC3164WithTimestamp rfc3164Timestamp++-- | Render a 'LogMessage' according to the rules in the RFC-3164 but use+-- RFC5424 time stamps.+renderRFC3164WithRFC5424Timestamps :: LogMessageRenderer T.Text+renderRFC3164WithRFC5424Timestamps =+  renderRFC3164WithTimestamp rfc5424Timestamp++-- | Render a 'LogMessage' according to the rules in the RFC-3164 but use the custom+-- 'LogMessageTimeRenderer'.+renderRFC3164WithTimestamp :: LogMessageTimeRenderer -> LogMessageRenderer T.Text+renderRFC3164WithTimestamp renderTime l@(MkLogMessage _ _ ts hn an pid mi _ _ _ _) =+  T.unwords+    . filter (not . T.null)+    $ [ renderSyslogSeverityAndFacility l -- PRI+      , maybe "1979-05-29T00:17:17.000001Z"+              (renderLogMessageTime renderTime)+              ts+      , fromMaybe "localhost" hn+      , fromMaybe "haskell" an <> maybe "" (("[" <>) . (<> "]")) pid <> ":"+      , fromMaybe "" mi+      , renderLogMessageBody l+      ]++-- | Render a 'LogMessage' according to the rules in the RFC-5424.+renderRFC5424 :: LogMessageRenderer T.Text+renderRFC5424 l@(MkLogMessage _ _ ts hn an pid mi sd _ _ _) =+  T.unwords+    . filter (not . T.null)+    $ [ renderSyslogSeverityAndFacility l <> "1" -- PRI VERSION+      , maybe "-" (renderLogMessageTime rfc5424Timestamp) ts+      , fromMaybe "-" hn+      , fromMaybe "-" an+      , fromMaybe "-" pid+      , fromMaybe "-" mi+      , structuredData+      , msg+      ]+ where+  structuredData = if null sd then "-" else T.concat (renderSdElement <$> sd)+  msg            = renderLogMessageBody l -- T.unwords (renderLogMessageBodyFixWidth l)++renderSdElement :: StructuredDataElement -> T.Text+renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params+  then ""+  else " " <> T.unwords (renderSdParameter <$> params) <> "]"++renderSdParameter :: SdParameter -> T.Text+renderSdParameter (MkSdParameter k v) =+  sdName k <> "=\"" <> sdParamValue v <> "\""++-- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424.+sdName :: T.Text -> T.Text+sdName =+  T.take 32 . T.filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')++-- | Extract the value of an 'SdParameter'.+sdParamValue :: T.Text -> T.Text+sdParamValue = T.concatMap $ \case+  '"'  -> "\\\""+  '\\' -> "\\\\"+  ']'  -> "\\]"+  x    -> T.singleton x

@@ -15,28 +15,14 @@   , runLogWriterReader   -- * LogWriter Handler Class   , HandleLogWriter(..)-  -- ** 'LogWriter' Handler Instance Zoo-  -- *** Pure Writer   , noOpLogWriter-  , debugTraceLogWriter   , PureLogWriter(..)-  -- *** List Writer-  , listLogWriter-  , CaptureLogs(..)-  , CapturedLogsWriter-  , runCapturedLogsWriter-  -- *** IO Writer-  , consoleLogWriter-  , ioHandleLogWriter   -- ** Writer Combinator   -- *** Pure Writer Combinator   , filteringLogWriter   , mappingLogWriter   -- *** Impure Writer Combinator   , mappingLogWriterM-  -- *** IO Based Combinator-  , ioLogWriter-  , defaultIoLogWriter   ) where @@ -45,16 +31,8 @@ import           Control.Eff.Log.Message import           Data.Default import           Data.Function                  ( fix )-import           Debug.Trace-import           GHC.Stack-import           Control.Eff.Writer.Strict      ( Writer-                                                , tell-                                                , runListWriter-                                                ) import           Data.Functor.Identity          ( Identity ) import           Control.DeepSeq                ( force )-import           Data.Foldable                  ( traverse_ )-import qualified System.IO                     as IO import           Control.Monad                  ( (>=>)                                                 , when                                                 )@@ -183,6 +161,10 @@     w <- askLogWriter     handleLogWriterEffect (runLogWriter w m) +instance HandleLogWriter IO where+  type LogWriterEffects IO = '[Lift IO]+  handleLogWriterEffect = send . Lift+ -- ** Pure Log Writers  -- | A phantom type for the 'HandleLogWriter' class for /pure/ 'LogWriter's@@ -199,82 +181,6 @@ -- NOTE: This is just an alias for 'def' noOpLogWriter :: Applicative m => LogWriter m noOpLogWriter = def---- | A 'LogWriter' that applies 'renderLogMessage' to the log message and then--- traces it using 'traceM'.--- This 'LogWriter' work with /any/ base monad.-debugTraceLogWriter :: Monad h => LogWriter h-debugTraceLogWriter = MkLogWriter (traceM . renderLogMessage)---- ** Impure logging---- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.-listLogWriter :: LogWriter CaptureLogs-listLogWriter = MkLogWriter (MkCaptureLogs . tell)---- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.-newtype CaptureLogs a = MkCaptureLogs { unCaptureLogs :: Eff '[CapturedLogsWriter] a }-  deriving (Functor, Applicative, Monad)---- | A 'LogWriter' monad for pure logging.------ The 'HandleLogWriter' instance for this type assumes a 'Writer' effect.-instance HandleLogWriter CaptureLogs where-  type LogWriterEffects CaptureLogs = '[CapturedLogsWriter]-  handleLogWriterEffect =-    traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs---- | Run a 'Writer' for 'LogMessage's.------ Such a 'Writer' is needed for 'CaptureLogs'-runCapturedLogsWriter-  :: Eff (CapturedLogsWriter ': e) a -> Eff e (a, [LogMessage])-runCapturedLogsWriter = runListWriter---- | Alias for the 'Writer' that contains the captured 'LogMessage's from 'CaptureLogs'.-type CapturedLogsWriter = Writer LogMessage---- | A 'LogWriter' that uses an 'IO' action to write the message.------ Example use cases for this function are the 'consoleLogWriter' and the 'ioHandleLogWriter'.-ioLogWriter :: HasCallStack => (LogMessage -> IO ()) -> LogWriter IO-ioLogWriter = MkLogWriter---- | A 'LogWriter' that renders 'LogMessage's to strings via 'renderLogMessage'--- and prints them to an 'IO.Handle' using 'hPutStrLn'.-ioHandleLogWriter :: HasCallStack => IO.Handle -> LogWriter IO-ioHandleLogWriter h = ioLogWriter (IO.hPutStrLn h . renderLogMessage)--instance HandleLogWriter IO where-  type LogWriterEffects IO = '[Lift IO]-  handleLogWriterEffect = send . Lift---- | Write 'LogMessage's to standard output, formatted with 'printLogMessage'.-consoleLogWriter :: LogWriter IO-consoleLogWriter = ioLogWriter printLogMessage---- | Decorate an IO based 'LogWriter' to fill out these fields in 'LogMessage's:------ * The messages will carry the given application name in the 'lmAppName' field.--- * The 'lmTimestamp' field contains the UTC time of the log event--- * The 'lmThreadId' field contains the thread-Id--- * The 'lmHostname' field contains the FQDN of the current host--- * The 'lmFacility' field contains the given 'Facility'------ It works by using 'mappingLogWriterM'.-defaultIoLogWriter-  :: String -- ^ The default application name to put into the 'lmAppName' field.-  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.-  -> LogWriter IO -- ^ The IO based writer to decorate-  -> LogWriter IO-defaultIoLogWriter appName facility = mappingLogWriterM-  (   setLogMessageThreadId-  >=> setLogMessageTimestamp-  >=> setLogMessageHostname-  >=> pure-  .   set lmFacility facility-  .   set lmAppName  (Just appName)-  )  -- | A 'LogWriter' that applies a predicate to the 'LogMessage' and delegates to -- to the given writer of the predicate is satisfied.

@@ -0,0 +1,119 @@+-- | This module only exposes a 'LogWriter' for asynchronous logging;+module Control.Eff.LogWriter.Async+  ( withAsyncLogWriter+  , withAsyncLogging+  )+where++import           Control.Concurrent.Async+import           Control.Concurrent.STM+import           Control.DeepSeq+import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           Control.Exception              ( evaluate )+import           Control.Monad                  ( unless )+import           Control.Monad.Trans.Control    ( MonadBaseControl+                                                , liftBaseOp+                                                )+import           Data.Foldable                  ( traverse_ )+import           Data.Kind                      ( )+import           Data.Text                     as T+++-- | This is a wrapper around 'withAsyncLogWriter' and 'withIoLogging'.+--+-- Example:+--+-- > exampleWithAsyncLogging :: IO ()+-- > exampleWithAsyncLogging =+-- >     runLift+-- >   $ withAsyncLogWriter consoleLogWriter (1000::Int) "my-app" local0 allLogMessages+-- >   $ do logMsg "test 1"+-- >        logMsg "test 2"+-- >        logMsg "test 3"+-- >+--+withAsyncLogging+  :: (LogsTo IO e, Lifted IO e, MonadBaseControl IO (Eff e), Integral len)+  => LogWriter IO+  -> len -- ^ Size of the log message input queue. If the queue is full, message+         -- are dropped silently.+  -> Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withAsyncLogging lw queueLength a f p e = liftBaseOp+  (withAsyncLogChannel queueLength (runLogWriter lw . force))+  (\lc -> withIoLogging (makeLogChannelWriter lc) a f p e)+++-- | /Move/ the current 'LogWriter' into its own thread.+--+-- A bounded queue is used to forward logs to the process.+--+-- If an exception is received, the logging process will be killed.+--+-- Log messages are deeply evaluated before being sent to the logger process,+-- to prevent that lazy evaluation leads to heavy work being done in the+-- logger process instead of the caller process.+--+-- Example:+--+-- > exampleAsyncLogWriter :: IO ()+-- > exampleAsyncLogWriter =+-- >     runLift+-- >   $ withLogging consoleLogWriter+-- >   $ withAsyncLogWriter (1000::Int)+-- >   $ do logMsg "test 1"+-- >        logMsg "test 2"+-- >        logMsg "test 3"+-- >+--+withAsyncLogWriter+  :: (LogsTo IO e, Lifted IO e, MonadBaseControl IO (Eff e), Integral len)+  => len -- ^ Size of the log message input queue. If the queue is full, message+         -- are dropped silently.+  -> Eff e a+  -> Eff e a+withAsyncLogWriter queueLength e = do+  lw <- askLogWriter+  liftBaseOp (withAsyncLogChannel queueLength (runLogWriter lw . force))+             (\lc -> setLogWriter (makeLogChannelWriter lc) e)++withAsyncLogChannel+  :: forall a len+   . (Integral len)+  => len+  -> (LogMessage -> IO ())+  -> (LogChannel -> IO a)+  -> IO a+withAsyncLogChannel queueLen ioWriter action = do+  msgQ <- newTBQueueIO (fromIntegral queueLen)+  withAsync (logLoop msgQ) (action . ConcurrentLogChannel msgQ)+ where+  logLoop tq = do+    ms <- atomically $ do+      h <- readTBQueue tq+      t <- flushTBQueue tq+      return (h : t)+    traverse_ ioWriter ms+    logLoop tq++makeLogChannelWriter :: LogChannel -> LogWriter IO+makeLogChannelWriter lc = mkLogWriterIO logChannelPutIO+ where+  logChannelPutIO (force -> me) = do+    !m <- evaluate me+    atomically+      (do+        dropMessage <- isFullTBQueue logQ+        unless dropMessage (writeTBQueue logQ m)+      )+  logQ = fromLogChannel lc++data LogChannel = ConcurrentLogChannel+  { fromLogChannel :: TBQueue LogMessage+  , _logChannelThread :: Async ()+  }

@@ -0,0 +1,46 @@+-- | Capture 'LogMessage's to a 'Writer'.+--+-- See 'Control.Eff.Log.Examples.exampleLogCapture'+module Control.Eff.LogWriter.Capture+  ( captureLogWriter+  , CaptureLogs(..)+  , CaptureLogWriter+  , runCaptureLogWriter+  )+where++import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.Writer.Strict      ( Writer+                                                , tell+                                                , runListWriter+                                                )+import           Data.Foldable                  ( traverse_ )++-- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.+--+-- See 'Control.Eff.Log.Examples.exampleLogCapture'+captureLogWriter :: LogWriter CaptureLogs+captureLogWriter = MkLogWriter (MkCaptureLogs . tell)++-- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.+newtype CaptureLogs a = MkCaptureLogs { unCaptureLogs :: Eff '[CaptureLogWriter] a }+  deriving (Functor, Applicative, Monad)++-- | A 'LogWriter' monad for pure logging.+--+-- The 'HandleLogWriter' instance for this type assumes a 'Writer' effect.+instance HandleLogWriter CaptureLogs where+  type LogWriterEffects CaptureLogs = '[CaptureLogWriter]+  handleLogWriterEffect =+    traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs++-- | Run a 'Writer' for 'LogMessage's.+--+-- Such a 'Writer' is needed to handle 'CaptureLogWriter'+runCaptureLogWriter+  :: Eff (CaptureLogWriter ': e) a -> Eff e (a, [LogMessage])+runCaptureLogWriter = runListWriter++-- | Alias for the 'Writer' that contains the captured 'LogMessage's from 'CaptureLogs'.+type CaptureLogWriter = Writer LogMessage

@@ -0,0 +1,64 @@+-- | This helps to setup logging to /standard ouput/.+module Control.Eff.LogWriter.Console+  ( withConsoleLogWriter+  , withConsoleLogging+  , consoleLogWriter+  , stdoutLogWriter+  ) where++import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.IO+import Data.Text+import qualified Data.Text.IO                  as T++-- | Enable logging to @standard output@ using the 'consoleLogWriter', with some 'LogMessage' fields preset+-- as in 'withIoLogging'.+--+-- Log messages are rendered using 'renderLogMessageConsoleLog'.+--+-- Example:+--+-- > exampleWithConsoleLogging :: IO ()+-- > exampleWithConsoleLogging =+-- >     runLift+-- >   $ withConsoleLogging "my-app" local7 allLogMessages+-- >   $ logInfo "Oh, hi there"+--+-- To vary the 'LogWriter' use 'withIoLogging'.+withConsoleLogging+  :: Lifted IO e+  => Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withConsoleLogging = withIoLogging consoleLogWriter+++-- | Enable logging to @standard output@ using the 'consoleLogWriter'.+--+-- Log messages are rendered using 'renderLogMessageConsoleLog'.+--+-- Example:+--+-- > exampleWithConsoleLogWriter :: IO ()+-- > exampleWithConsoleLogWriter =+-- >     runLift+-- >   $ withSomeLogging @IO+-- >   $ withConsoleLogWriter+-- >   $ logInfo "Oh, hi there"+withConsoleLogWriter+  :: (LogsTo IO e, Lifted IO e)+  => Eff e a -> Eff e a+withConsoleLogWriter = addLogWriter consoleLogWriter++-- | Write 'LogMessage's to standard output, formatted with 'printLogMessage'.+--+-- It uses 'stdoutLogWriter' with 'renderLogMessageConsoleLog'.+consoleLogWriter :: LogWriter IO+consoleLogWriter = mkLogWriterIO (T.putStrLn . renderLogMessageConsoleLog)++-- | A 'LogWriter' that uses a 'LogMessageRenderer' to render, and 'T.putStrLn' to print it.+stdoutLogWriter :: LogMessageRenderer Text -> LogWriter IO+stdoutLogWriter render = mkLogWriterIO (T.putStrLn . render)

@@ -0,0 +1,55 @@+-- | This helps to setup logging via "Debug.Trace".+module Control.Eff.LogWriter.DebugTrace+  ( withTraceLogWriter+  , withTraceLogging+  , debugTraceLogWriter+  )+where++import           Debug.Trace+import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           Data.Text                     as T++-- | Enable logging via 'traceM' using the 'debugTraceLogWriter', with some 'LogMessage' fields preset+-- as in 'withIoLogging'.+--+-- Log messages are rendered using 'renderLogMessageConsoleLog'.+--+-- Example:+--+-- > exampleWithTraceLogging :: IO ()+-- > exampleWithTraceLogging =+-- >     runLift+-- >   $ withTraceLogging "my-app" local7 allLogMessages+-- >   $ logInfo "Oh, hi there"+withTraceLogging+  :: Lifted IO e+  => Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withTraceLogging = withIoLogging (debugTraceLogWriter renderLogMessageConsoleLog)+++-- | Enable logging via 'traceM' using the 'debugTraceLogWriter'. The+-- logging monad type can be /any/ type with a 'Monad' instance.+--+-- Log messages are rendered using 'renderLogMessageConsoleLog'.+--+-- Example:+--+-- > exampleWithTraceLogWriter :: IO ()+-- > exampleWithTraceLogWriter =+-- >     runLift+-- >   $ withSomeLogging @IO+-- >   $ withTraceLogWriter+-- >   $ logInfo "Oh, hi there"+withTraceLogWriter :: forall h e a . (Monad h, LogsTo h e) => Eff e a -> Eff e a+withTraceLogWriter = addLogWriter @h (debugTraceLogWriter renderLogMessageConsoleLog)++-- | Write 'LogMessage's  via 'traceM'.+debugTraceLogWriter :: forall h . (Monad h) => LogMessageRenderer Text -> LogWriter h+debugTraceLogWriter render = MkLogWriter (traceM . T.unpack . render)

@@ -0,0 +1,79 @@+-- | This helps to setup logging to a /file/.+module Control.Eff.LogWriter.File+  ( withFileLogging+  , withFileLogWriter+  )+where++import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           GHC.Stack+import           Data.Text                     as T+import qualified System.IO                     as IO+import           System.Directory               ( canonicalizePath+                                                , createDirectoryIfMissing+                                                )+import           System.FilePath                ( takeDirectory )+import qualified Control.Exception.Safe        as Safe+import qualified Control.Monad.Catch           as Catch+import           Control.Monad.Trans.Control    ( MonadBaseControl+                                                , liftBaseOp+                                                )++-- | Enable logging to a file, with some 'LogMessage' fields preset+-- as described in 'withIoLogging'.+--+-- If the file or its directory does not exist, it will be created.+--+-- Example:+--+-- > exampleWithFileLogging :: IO ()+-- > exampleWithFileLogging =+-- >     runLift+-- >   $ withFileLogging "/var/log/my-app.log" "my-app" local7 allLogMessages+-- >   $ logInfo "Oh, hi there"+--+-- To vary the 'LogWriter' use 'withIoLogging'.+withFileLogging+  :: (Lifted IO e, MonadBaseControl IO (Eff e))+  => FilePath -- ^ Path to the log-file.+  -> Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withFileLogging fnIn a f p e =+  liftBaseOp (withOpenedLogFile fnIn) (\lw -> withIoLogging lw a f p e)+++-- | Enable logging to a file.+--+-- If the file or its directory does not exist, it will be created.+-- Example:+--+-- > exampleWithFileLogWriter :: IO ()+-- > exampleWithFileLogWriter =+-- >     runLift+-- >   $ withSomeLogging @IO+-- >   $ withFileLogWriter "test.log"+-- >   $ logInfo "Oh, hi there"+withFileLogWriter+  :: (Lifted IO e, LogsTo IO e, MonadBaseControl IO (Eff e))+  => FilePath -- ^ Path to the log-file.+  -> Eff e b+  -> Eff e b+withFileLogWriter fnIn e =+  liftBaseOp (withOpenedLogFile fnIn) (`addLogWriter` e)++withOpenedLogFile :: HasCallStack => FilePath -> (LogWriter IO -> IO a) -> IO a+withOpenedLogFile fnIn ioE = Safe.bracket+  (do+    fnCanon <- canonicalizePath fnIn+    createDirectoryIfMissing True (takeDirectory fnCanon)+    h <- IO.openFile fnCanon IO.AppendMode+    IO.hSetBuffering h (IO.BlockBuffering (Just 1024))+    return h+  )+  (\h -> Safe.try @IO @Catch.SomeException (IO.hFlush h) >> IO.hClose h)+  (\h -> ioE (ioHandleLogWriter h))

@@ -0,0 +1,89 @@+-- | Functions for generic, IO-based 'LogWriter's.+--+-- This module is more low-level than the others in this directory.+module Control.Eff.LogWriter.IO+  ( mkLogWriterIO+  , ioHandleLogWriter+  , defaultIoLogWriter+  , withIoLogging+  , LoggingAndIo+  , printLogMessage+  )+where++import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Monad                  ( (>=>) )+import           Control.Lens                   (set)+import           Data.Text+import qualified System.IO                     as IO+import           GHC.Stack+import qualified Data.Text.IO                  as T++-- | A 'LogWriter' that uses an 'IO' action to write the message.+--+-- This is just an alias for 'MkLogWriter' but with @IO@ as parameter. This reduces the need to+-- apply something to the extra type argument @\@IO@.+--+-- Example use cases for this function are the 'consoleLogWriter' and the 'ioHandleLogWriter'.+mkLogWriterIO :: HasCallStack => (LogMessage -> IO ()) -> LogWriter IO+mkLogWriterIO = MkLogWriter++-- | A 'LogWriter' that renders 'LogMessage's to strings via 'renderLogMessageConsoleLog'+-- and prints them to an 'IO.Handle' using 'hPutStrLn'.+ioHandleLogWriter :: HasCallStack => IO.Handle -> LogWriter IO+ioHandleLogWriter h =+  mkLogWriterIO (T.hPutStrLn h . renderLogMessageConsoleLog)++-- | Enable logging to IO using the 'defaultIoLogWriter'.+--+-- Example:+--+-- > exampleWithIoLogging :: IO ()+-- > exampleWithIoLogging =+-- >     runLift+-- >   $ withIoLogging debugTraceLogWriter+-- >                   "my-app"+-- >                   local7+-- >                   (lmSeverityIsAtLeast informationalSeverity)+-- >   $ logInfo "Oh, hi there"+--+withIoLogging+  :: SetMember Lift (Lift IO) e+  => LogWriter IO -- ^ The 'LogWriter' that will be used to write log messages.+  -> Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withIoLogging lw appName facility defaultPredicate =+  withLogging (defaultIoLogWriter appName facility lw)+    . setLogPredicate defaultPredicate++-- | Decorate an IO based 'LogWriter' to fill out these fields in 'LogMessage's:+--+-- * The messages will carry the given application name in the 'lmAppName' field.+-- * The 'lmTimestamp' field contains the UTC time of the log event+-- * The 'lmHostname' field contains the FQDN of the current host+-- * The 'lmFacility' field contains the given 'Facility'+--+-- It works by using 'mappingLogWriterM'.+defaultIoLogWriter+  :: Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogWriter IO -- ^ The IO based writer to decorate+  -> LogWriter IO+defaultIoLogWriter appName facility = mappingLogWriterM+  (   setLogMessageTimestamp+  >=> setLogMessageHostname+  >=> pure+  .   set lmFacility facility+  .   set lmAppName  (Just appName)+  )++-- | The concrete list of 'Eff'ects for logging with an IO based 'LogWriter', and a 'LogWriterReader'.+type LoggingAndIo = '[Logs, LogWriterReader IO, Lift IO]++-- | Render a 'LogMessage' but set the timestamp and thread id fields.+printLogMessage :: LogMessage -> IO ()+printLogMessage = T.putStrLn . renderLogMessageConsoleLog

@@ -0,0 +1,87 @@+-- | This helps to setup logging to /standard ouput/.+module Control.Eff.LogWriter.UDP+  ( withUDPLogWriter+  , withUDPLogging+  )+where++import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.LogWriter.Console+import           Control.Eff.LogWriter.IO+import           Data.Text                     as T+import           Data.Text.IO                  as T+import           Data.Text.Encoding            as T+import qualified Control.Exception.Safe        as Safe+import           Control.Monad                  ( void )+import qualified Control.Monad.Catch           as Catch+import           Control.Monad.Trans.Control    ( MonadBaseControl+                                                , liftBaseOp+                                                )+import           GHC.Stack+import qualified System.Socket                 as Socket+import           System.Socket.Type.Datagram   as Socket+import           System.Socket.Family.Inet     as Socket+import qualified System.Socket.Protocol.UDP    as Socket++-- | Enable logging to a remote host via __UDP__, with some 'LogMessage' fields preset+-- as in 'withIoLogging'.+--+-- See 'Control.Eff.Log.Examples.exampleUdpRFC3164Logging'+withUDPLogging+  :: (HasCallStack, MonadBaseControl IO (Eff e), Lifted IO e)+  => (LogMessage -> Text) -- ^ 'LogMessage' rendering function+  -> Text -- ^ Hostname or IP+  -> Text -- ^ Port e.g. @"514"@+  -> Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withUDPLogging render hostname port a f p e = liftBaseOp+  (withUDPSocket render hostname port)+  (\lw -> withIoLogging lw a f p e)+++-- | Enable logging to a (remote-) host via UDP.+--+-- See 'Control.Eff.Log.Examples.exampleUdpRFC3164Logging'+withUDPLogWriter+  :: (Lifted IO e, LogsTo IO e, MonadBaseControl IO (Eff e), HasCallStack)+  => (LogMessage -> Text) -- ^ 'LogMessage' rendering function+  -> Text -- ^ Hostname or IP+  -> Text -- ^ Port e.g. @"514"@+  -> Eff e b+  -> Eff e b+withUDPLogWriter render hostname port e =+  liftBaseOp (withUDPSocket render hostname port) (`addLogWriter` e)+++withUDPSocket+  :: HasCallStack+  => (LogMessage -> Text) -- ^ 'LogMessage' rendering function+  -> Text -- ^ Hostname or IP+  -> Text -- ^ Port e.g. @"514"@+  -> (LogWriter IO -> IO a)+  -> IO a+withUDPSocket render hostname port ioE = Safe.bracket+  (Socket.socket :: IO (Socket.Socket Inet Datagram Socket.UDP))+  (Safe.try @IO @Catch.SomeException . Socket.close)+  (\s -> do+    ai <- Socket.getAddressInfo (Just (T.encodeUtf8 hostname))+                                (Just (T.encodeUtf8 port))+                                mempty+    case ai :: [Socket.AddressInfo Inet Datagram Socket.UDP] of+      (a : _) -> do+        let addr = Socket.socketAddress a+        ioE+          (mkLogWriterIO+            (\lmStr -> void+              $ Socket.sendTo s (T.encodeUtf8 (render lmStr)) Socket.msgNoSignal addr+            )+          )++      [] -> do+        T.putStrLn ("could not resolve UDP syslog server: " <> hostname)+        ioE consoleLogWriter+  )

@@ -0,0 +1,79 @@+-- | This helps to setup logging to /standard ouput/.+module Control.Eff.LogWriter.UnixSocket+  ( withUnixSocketLogWriter+  , withUnixSocketLogging+  )+where++import           Control.Eff                   as Eff+import           Control.Eff.Log+import           Control.Eff.LogWriter.IO+import           Control.Eff.LogWriter.Console+import           Data.Text                     as T+import           Data.Text.IO                  as T+import           Data.Text.Encoding            as T+import qualified Control.Exception.Safe        as Safe+import           Control.Monad                  ( void )+import qualified Control.Monad.Catch           as Catch+import           Control.Monad.Trans.Control    ( MonadBaseControl+                                                , liftBaseOp+                                                )+import           GHC.Stack+import qualified System.Socket                 as Socket+import           System.Socket.Type.Datagram   as Socket+import           System.Socket.Family.Unix     as Socket+import qualified System.Socket.Protocol.Default+                                               as Socket++-- | Enable logging to a /unix domain socket/, with some 'LogMessage' fields preset+-- as in 'withIoLogging'.+--+-- See 'Control.Eff.Log.Examples.exampleDevLogSyslogLogging'+withUnixSocketLogging+  :: (HasCallStack, MonadBaseControl IO (Eff e), Lifted IO e)+  => LogMessageRenderer Text -- ^ 'LogMessage' rendering function+  -> FilePath -- ^ Path to the socket file+  -> Text -- ^ The default application name to put into the 'lmAppName' field.+  -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.+  -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withUnixSocketLogging render socketPath a f p e = liftBaseOp+  (withUnixSocketSocket render socketPath)+  (\lw -> withIoLogging lw a f p e)++-- | Enable logging to a (remote-) host via UnixSocket.+--+-- See 'Control.Eff.Log.Examples.exampleDevLogSyslogLogging'+withUnixSocketLogWriter+  :: (Lifted IO e, LogsTo IO e, MonadBaseControl IO (Eff e), HasCallStack)+  => LogMessageRenderer Text -- ^ 'LogMessage' rendering function+  -> FilePath -- ^ Path to the socket file+  -> Eff e b+  -> Eff e b+withUnixSocketLogWriter render socketPath e =+  liftBaseOp (withUnixSocketSocket render socketPath) (`addLogWriter` e)++withUnixSocketSocket+  :: HasCallStack+  => LogMessageRenderer Text -- ^ 'LogMessage' rendering function+  -> FilePath -- ^ Path to the socket file+  -> (LogWriter IO -> IO a)+  -> IO a+withUnixSocketSocket render socketPath ioE = Safe.bracket+  (Socket.socket :: IO (Socket.Socket Unix Datagram Socket.Default))+  (Safe.try @IO @Catch.SomeException . Socket.close)+  (\s -> case socketAddressUnixPath (T.encodeUtf8 (T.pack socketPath)) of+    Just addr -> do+      Socket.connect s addr+      ioE+        (mkLogWriterIO+          (\lmStr -> void+            $ Socket.send s (T.encodeUtf8 (render lmStr)) Socket.msgNoSignal+          )+        )++    Nothing -> do+      T.putStrLn $ "could not open unix domain socket: " <> T.pack socketPath+      ioE consoleLogWriter+  )

@@ -41,6 +41,9 @@   # (e.g., acme-missiles-0.3) extra-deps:   - extensible-effects-5.0.0.1+  - socket-unix-0.2.0.0+  - socket-0.8.2.0+   # Override default flag values for local packages and extra-deps   # flags: {}   # Extra package databases containing global packages

@@ -57,7 +57,7 @@       , void (send (ReceiveSelectedMessage @SchedulerIO selectAnyMessageLazy))       )     , ( "sending"-      , void (send (SendMessage @SchedulerIO 44444 (toDyn "test message")))+      , void (send (SendMessage @SchedulerIO 44444 (toDyn ("test message" :: String))))       )     , ( "sending shutdown"       , void (send (SendShutdown @SchedulerIO 44444 ExitNormally))@@ -113,7 +113,7 @@       "spawn a child with a busy send loop and exit normally"         (Scheduler.defaultMain           (do-            void (spawn (foreverCheap (void (sendMessage 1000 "test"))))+            void (spawn (foreverCheap (void (sendMessage 1000 ("test" :: String)))))             void exitNormally             fail "This should not happen!!"           )@@ -128,7 +128,7 @@     (Scheduler.defaultMain         (do           child <- spawn (void (receiveMessage @String))-          sendMessage child "test"+          sendMessage child ("test" :: String)           return ()         )   ))@@ -145,7 +145,7 @@                   void exitNormally                   error "This should not happen (child)!!"                 )-              sendMessage child "test"+              sendMessage child ("test" :: String)               void exitNormally               error "This should not happen!!"             )@@ -161,22 +161,22 @@         let n = 100             testMsg :: Float             testMsg   = 123-            flushMessages = do+            flushMessagesLoop = do               res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 0               case res of                 Left  _to -> return ()-                Right _   -> flushMessages+                Right _   -> flushMessagesLoop         me <- self         spawn_           (do-            replicateM_ n $ sendMessage me "bad message"+            replicateM_ n $ sendMessage me ("bad message" :: String)             replicateM_ n $ sendMessage me (3123 :: Integer)             sendMessage me testMsg           )         do           res <- receiveAfter @Float 1000000           lift (res @?= Just testMsg)-        flushMessages+        flushMessagesLoop         res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 10000         case res of           Left  _ -> return ()

@@ -0,0 +1,482 @@+module LogMessageIdeaTest where++import           Control.Concurrent+import           Control.DeepSeq+import           Control.Lens+import           Data.Default+import           Data.Maybe+import qualified Data.Text                     as T+import           Data.Time.Clock+import           Data.Time.Format+import           GHC.Generics            hiding ( to )+import           GHC.Stack+import           System.FilePath.Posix+import           Text.Printf+import           Control.Eff+import           Control.Eff.Reader.Lazy+++-- | A message data type inspired by the RFC-5424 Syslog Protocol+data LogMessage =+  MkLogMessage { _lmFacility :: !Facility+               , _lmSeverity :: !Severity+               , _lmTimestamp :: (Maybe UTCTime)+               , _lmHostname :: (Maybe T.Text)+               , _lmAppName :: (Maybe T.Text)+               , _lmProcessId :: (Maybe T.Text)+               , _lmMessageId :: (Maybe T.Text)+               , _lmStructuredData :: [StructuredDataElement]+               , _lmThreadId :: (Maybe ThreadId)+               , _lmSrcLoc :: (Maybe SrcLoc)+               , _lmMessage :: T.Text}+  deriving (Eq, Generic)++instance Default LogMessage where+  def = MkLogMessage def def def def def def def def def def ""++instance NFData LogMessage++-- | RFC-5424 defines how structured data can be included in a log message.+data StructuredDataElement =+  SdElement { _sdElementId :: !T.Text+            , _sdElementParameters :: ![SdParameter]}+  deriving (Eq, Ord, Generic, Show)+++renderSdElement :: StructuredDataElement -> T.Text+renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params+  then ""+  else " " <> T.unwords (renderSdParameter <$> params) <> "]"++instance NFData StructuredDataElement++-- | Component of an RFC-5424 'StructuredDataElement'+data SdParameter =+  MkSdParameter !T.Text !T.Text+  deriving (Eq, Ord, Generic, Show)++renderSdParameter :: SdParameter -> T.Text+renderSdParameter (MkSdParameter k v) =+  sdName k <> "=\"" <> sdParamValue v <> "\""++-- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424.+sdName :: T.Text -> T.Text+sdName =+  T.take 32 . T.filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')++-- | Extract the value of an 'SdParameter'.+sdParamValue :: T.Text -> T.Text+sdParamValue = T.concatMap $ \case+  '"'  -> "\\\""+  '\\' -> "\\\\"+  ']'  -> "\\]"+  x    -> T.singleton x++instance NFData SdParameter++-- | An rfc 5424 severity+newtype Severity =+  Severity {fromSeverity :: Int}+  deriving (Eq, Ord, Generic, NFData)++instance Show Severity where+  show (Severity 1) = "ALERT    "+  show (Severity 2) = "CRITICAL "+  show (Severity 3) = "ERROR    "+  show (Severity 4) = "WARNING  "+  show (Severity 5) = "NOTICE   "+  show (Severity 6) = "INFO     "+  show (Severity x) | x <= 0    = "EMERGENCY"+                    | otherwise = "DEBUG    "+--  *** Severities++-- | Smart constructor for the RFC-5424 __emergency__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __0__.+-- See 'lmSeverity'.+emergencySeverity :: Severity+emergencySeverity = Severity 0++-- | Smart constructor for the RFC-5424 __alert__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __1__.+-- See 'lmSeverity'.+alertSeverity :: Severity+alertSeverity = Severity 1++-- | Smart constructor for the RFC-5424 __critical__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __2__.+-- See 'lmSeverity'.+criticalSeverity :: Severity+criticalSeverity = Severity 2++-- | Smart constructor for the RFC-5424 __error__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __3__.+-- See 'lmSeverity'.+errorSeverity :: Severity+errorSeverity = Severity 3++-- | Smart constructor for the RFC-5424 __warning__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __4__.+-- See 'lmSeverity'.+warningSeverity :: Severity+warningSeverity = Severity 4++-- | Smart constructor for the RFC-5424 __notice__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __5__.+-- See 'lmSeverity'.+noticeSeverity :: Severity+noticeSeverity = Severity 5++-- | Smart constructor for the RFC-5424 __informational__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __6__.+-- See 'lmSeverity'.+informationalSeverity :: Severity+informationalSeverity = Severity 6++-- | Smart constructor for the RFC-5424 __debug__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __7__.+-- See 'lmSeverity'.+debugSeverity :: Severity+debugSeverity = Severity 7++instance Default Severity where+  def = debugSeverity+++-- | An rfc 5424 facility+newtype Facility = Facility {fromFacility :: Int}+  deriving (Eq, Ord, Show, Generic, NFData)++-- | Smart constructor for the RFC-5424 'LogMessage' facility @kernelMessages@.+-- See 'lmFacility'.+kernelMessages :: Facility+kernelMessages = Facility 0++-- | Smart constructor for the RFC-5424 'LogMessage' facility @userLevelMessages@.+-- See 'lmFacility'.+userLevelMessages :: Facility+userLevelMessages = Facility 1++-- | Smart constructor for the RFC-5424 'LogMessage' facility @mailSystem@.+-- See 'lmFacility'.+mailSystem :: Facility+mailSystem = Facility 2++-- | Smart constructor for the RFC-5424 'LogMessage' facility @systemDaemons@.+-- See 'lmFacility'.+systemDaemons :: Facility+systemDaemons = Facility 3++-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages4@.+-- See 'lmFacility'.+securityAuthorizationMessages4 :: Facility+securityAuthorizationMessages4 = Facility 4++-- | Smart constructor for the RFC-5424 'LogMessage' facility @linePrinterSubsystem@.+-- See 'lmFacility'.+linePrinterSubsystem :: Facility+linePrinterSubsystem = Facility 6++-- | Smart constructor for the RFC-5424 'LogMessage' facility @networkNewsSubsystem@.+-- See 'lmFacility'.+networkNewsSubsystem :: Facility+networkNewsSubsystem = Facility 7++-- | Smart constructor for the RFC-5424 'LogMessage' facility @uucpSubsystem@.+-- See 'lmFacility'.+uucpSubsystem :: Facility+uucpSubsystem = Facility 8++-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon@.+-- See 'lmFacility'.+clockDaemon :: Facility+clockDaemon = Facility 9++-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages10@.+-- See 'lmFacility'.+securityAuthorizationMessages10 :: Facility+securityAuthorizationMessages10 = Facility 10++-- | Smart constructor for the RFC-5424 'LogMessage' facility @ftpDaemon@.+-- See 'lmFacility'.+ftpDaemon :: Facility+ftpDaemon = Facility 11++-- | Smart constructor for the RFC-5424 'LogMessage' facility @ntpSubsystem@.+-- See 'lmFacility'.+ntpSubsystem :: Facility+ntpSubsystem = Facility 12++-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAuditFacility@.+-- See 'lmFacility'.+logAuditFacility :: Facility+logAuditFacility = Facility 13++-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAlertFacility@.+-- See 'lmFacility'.+logAlertFacility :: Facility+logAlertFacility = Facility 14++-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon2@.+-- See 'lmFacility'.+clockDaemon2 :: Facility+clockDaemon2 = Facility 15++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local0@.+-- See 'lmFacility'.+local0 :: Facility+local0 = Facility 16++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local1@.+-- See 'lmFacility'.+local1 :: Facility+local1 = Facility 17++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local2@.+-- See 'lmFacility'.+local2 :: Facility+local2 = Facility 18++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local3@.+-- See 'lmFacility'.+local3 :: Facility+local3 = Facility 19++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local4@.+-- See 'lmFacility'.+local4 :: Facility+local4 = Facility 20++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local5@.+-- See 'lmFacility'.+local5 :: Facility+local5 = Facility 21++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local6@.+-- See 'lmFacility'.+local6 :: Facility+local6 = Facility 22++-- | Smart constructor for the RFC-5424 'LogMessage' facility @local7@.+-- See 'lmFacility'.+local7 :: Facility+local7 = Facility 23++instance Default Facility where+  def = local7++makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement++-- | A lens for 'SdParameter's+sdElementParameters+  :: Functor f+  => ([SdParameter] -> f [SdParameter])+  -> StructuredDataElement+  -> f StructuredDataElement++-- | A lens for the key or ID of a group of RFC 5424 key-value pairs.+sdElementId+  :: Functor f+  => (T.Text -> f T.Text)+  -> StructuredDataElement+  -> f StructuredDataElement++makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage++-- | A lens for the UTC time of a 'LogMessage'+-- The function 'setLogMessageTimestamp' can be used to set the field.+lmTimestamp+  :: Functor f+  => (Maybe UTCTime -> f (Maybe UTCTime))+  -> LogMessage+  -> f LogMessage++-- | A lens for the 'ThreadId' of a 'LogMessage'+-- The function 'setLogMessageThreadId' can be used to set the field.+lmThreadId+  :: Functor f+  => (Maybe ThreadId -> f (Maybe ThreadId))+  -> LogMessage+  -> f LogMessage++-- | A lens for the 'StructuredDataElement' of a 'LogMessage'+lmStructuredData+  :: Functor f+  => ([StructuredDataElement] -> f [StructuredDataElement])+  -> LogMessage+  -> f LogMessage++-- | A lens for the 'SrcLoc' of a 'LogMessage'+lmSrcLoc+  :: Functor f+  => (Maybe SrcLoc -> f (Maybe SrcLoc))+  -> LogMessage+  -> f LogMessage++-- | A lens for the 'Severity' of a 'LogMessage'+lmSeverity+  :: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage++-- | A lens for a user defined of /process/ id of a 'LogMessage'+lmProcessId+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage++-- | A lens for a user defined /message id/ of a 'LogMessage'+lmMessageId+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage++-- | A lens for the user defined textual message of a 'LogMessage'+lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage++-- | A lens for the hostname of a 'LogMessage'+-- The function 'setLogMessageHostname' can be used to set the field.+lmHostname+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage++-- | A lens for the 'Facility' of a 'LogMessage'+lmFacility+  :: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage++-- | A lens for the RFC 5424 /application/ name of a 'LogMessage'+--+-- One useful pattern for using this field, is to implement log filters that allow+-- info and debug message from the application itself while only allowing warning and error+-- messages from third party libraries:+--+-- > debugLogsForAppName myAppName lm =+-- >   view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm+--+-- This concept is also implemented in 'discriminateByAppName'.+lmAppName+  :: Functor f+  => (Maybe T.Text -> f (Maybe T.Text))+  -> LogMessage+  -> f LogMessage++instance Show LogMessage where+  show = T.unpack . T.unlines . renderLogMessageBodyFixWidth+++type LogRenderer a = LogMessage -> a++withRenderer :: LogRenderer a -> Eff (Reader (LogRenderer a) ': e) b -> Eff e b+withRenderer = runReader++newtype SeverityText = MkSeverityText { fromSeverityText :: T.Text }+  deriving (Semigroup)++mkSyslogSeverityText :: LogRenderer SeverityText+mkSyslogSeverityText (MkLogMessage !f !s _ _ _ _ _ _ _ _ _)+   = MkSeverityText $ "<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">"++newtype FacilityText = MkFacilityText { fromFacilityText :: T.Text }+  deriving (Semigroup)++mkSyslogFacilityText :: LogRenderer FacilityText+mkSyslogFacilityText _ = MkFacilityText ""++newtype TimestampText = MkTimestampText { fromTimestampText :: T.Text }+  deriving (Semigroup)++mkFormattedTimestampText :: LogTimestampFormat -> LogRenderer (Maybe TimestampText)+mkFormattedTimestampText f (MkLogMessage _ _ ts _ _ _ _ _ _ _ _) =+  MkTimestampText . formatLogTimestamp f <$> ts++newtype MessageText = MkMessageText { fromMessageText :: T.Text }+  deriving (Semigroup)++mkMessageText :: LogRenderer MessageText+mkMessageText = MkMessageText . renderLogMessageBody++renderDevLogMessage :: LogRenderer T.Text+renderDevLogMessage =+  run+    $ withRenderer mkSyslogSeverityText+    $ withRenderer mkSyslogFacilityText+    $ withRenderer mkMessageText+    $ withRenderer (fromMaybe (MkTimestampText "-") <$> mkFormattedTimestampText rfc5424NoZTimestamp)+    $ mkDevLogMessage++mkDevLogMessage ::+  ( '[ Reader (LogRenderer SeverityText)+     , Reader (LogRenderer FacilityText)+     , Reader (LogRenderer TimestampText)+     , Reader (LogRenderer MessageText)+     ]+    <:: e+  )+  => Eff e (LogRenderer T.Text)+mkDevLogMessage =+  (\s ts m -> s <> pure " " <> ts <> pure " " <> m)+    <$> (fmap fromSeverityText  <$> ask)+    <*> (fmap fromTimestampText <$> ask)+    <*> (fmap fromMessageText   <$> ask)+++-- | A time stamp formatting function+newtype LogTimestampFormat =+  MkLogTimestampFormat { formatLogTimestamp :: UTCTime -> T.Text }++-- | Make a  'LogTimestampFormat' using 'formatTime' in the 'defaultLocale'.+mkLogTimestampFormat+  :: String -- ^ The format string that is passed to 'formatTime'+  -> LogTimestampFormat+mkLogTimestampFormat s = MkLogTimestampFormat (T.pack . formatTime defaultTimeLocale s)++-- | Don't render the time stamp+suppressTimestamp :: LogTimestampFormat+suppressTimestamp = MkLogTimestampFormat (const "")++-- | Render the time stamp using @"%h %d %H:%M:%S"@+rfc3164Timestamp :: LogTimestampFormat+rfc3164Timestamp = mkLogTimestampFormat "%h %d %H:%M:%S"++-- | Render the time stamp to @'iso8601DateFormat' (Just "%H:%M:%S%6QZ")@+rfc5424Timestamp :: LogTimestampFormat+rfc5424Timestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6QZ"))++-- | Render the time stamp like 'rfc5424Timestamp' does, but omit the terminal @Z@ character.+rfc5424NoZTimestamp :: LogTimestampFormat+rfc5424NoZTimestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6Q"))++++-- | Print the /body/ of a 'LogMessage'+renderLogMessageBodyFixWidth :: LogMessage -> [T.Text]+renderLogMessageBodyFixWidth (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =+  if T.null msg+    then []+    else+      maybe "" ((<> " -") . T.pack . show) ti+      : (msg <> T.replicate (max 0 (60 - T.length msg)) " ")+      : maybe+          []+          (\sl -> pure+            (T.pack $ printf "% 30s line %i"+                             (takeFileName (srcLocFile sl))+                             (srcLocStartLine sl)+            )+          )+          loc++-- | Print the /body/ of a 'LogMessage' without any /tab-stops/+renderLogMessageBody :: LogMessage -> T.Text+renderLogMessageBody (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =+     maybe "" (\tis -> T.pack (show tis) <> " ") ti+  <> msg+  <> maybe+          ""+          (\sl ->+             T.pack $ printf " at %s:%i"+                             (takeFileName (srcLocFile sl))+                             (srcLocStartLine sl)+          )+          loc

@@ -1,7 +1,7 @@ module LoggingTests where  import           Control.Eff-import           Control.Eff.Log+import           Control.Eff.Concurrent import           Test.Tasty import           Test.Tasty.HUnit import           Common@@ -26,12 +26,12 @@       logInfo "jo"       logDebug "oh" -    pureLogs :: Eff '[Logs, LogWriterReader CaptureLogs, CapturedLogsWriter] a -> [LogMessage]+    pureLogs :: Eff '[Logs, LogWriterReader CaptureLogs, CaptureLogWriter] a -> [LogMessage]     pureLogs =         snd       . run-      . runCapturedLogsWriter-      . withLogging listLogWriter+      . runCaptureLogWriter+      . withLogging captureLogWriter       . censorLogs @CaptureLogs (lmSrcLoc .~ Nothing)  strictness :: HasCallStack => TestTree@@ -41,5 +41,4 @@     $ withLogging consoleLogWriter     $ excludeLogMessages (lmSeverityIs errorSeverity)     $ do logDebug "test"-         logMsg (errorMessage ("test" ++ error "TEST FAILED: this log statement should not have been evaluated deeply"))-+         logError' ("test" <> error "TEST FAILED: this log statement should not have been evaluated deeply")

@@ -14,6 +14,7 @@ import           Common import           Control.Eff.Concurrent.Process.SingleThreadedScheduler                                                as Scheduler+import           Data.Text.IO as T  test_loopTests :: TestTree test_loopTests =@@ -43,7 +44,7 @@             , testCase                     "'foreverCheap' inside a child process and 'replicateCheapM_' in the main process"                 $ do-                      res <- Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))+                      res <- Scheduler.scheduleIOWithLogging  (mkLogWriterIO (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))                               $ do                                     me <- self                                     spawn_ (foreverCheap $ sendMessage me ())@@ -64,7 +65,7 @@             [ testCase "scheduleMonadIOEff with many yields from replicateM_"                 $ do                       res <--                          Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))+                          Scheduler.scheduleIOWithLogging  (mkLogWriterIO (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))                               $ replicateM_ soMany yieldProcess                       res @=? Right ()             , testCase@@ -84,7 +85,7 @@                     "'forever' inside a child process and 'replicateM_' in the main process"                 $ do                       res <--                          Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))+                          Scheduler.scheduleIOWithLogging  (mkLogWriterIO (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))                               $ do                                     me <- self                                     spawn_ (forever $ sendMessage me ())

@@ -19,6 +19,9 @@ import           Control.Eff import           Control.Eff.Extend import           Control.Eff.Log+import           Control.Eff.LogWriter.Async+import           Control.Eff.LogWriter.Console+import           Control.Eff.LogWriter.IO import           Control.Eff.Loop import           Control.Monad import           Test.Tasty@@ -35,8 +38,8 @@ test_forkIo = setTravisTestOptions $ withTestLogC   (\c ->       runLift-    $ withSomeLogging @IO-    $ withAsyncLogging (100 :: Int) (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m)))+    $ withLogging (filteringLogWriter (lmSeverityIsAtLeast errorSeverity) consoleLogWriter)+    $ withAsyncLogWriter (100 :: Int)     $ ForkIO.schedule c)   (\factory -> testGroup "ForkIOScheduler" [allTests factory]) @@ -50,7 +53,7 @@         runEff =             runLift           . withLogging-              (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m)))+              (mkLogWriterIO (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m)))     in  void $ SingleThreaded.scheduleM runEff yield e   )   (\factory -> testGroup "SingleThreadedScheduler" [allTests factory])@@ -166,7 +169,7 @@       spawn_         $  replicateM_ 10 (sendMessage me (123.23411 :: Float))         >> sendMessage me ()-      spawn_ $ replicateM_ 10 (sendMessage me "123") >> sendMessage me ()+      spawn_ $ replicateM_ 10 (sendMessage me ("123"::String)) >> sendMessage me ()       ()   <- receiveMessage       ()   <- receiveMessage       ()   <- receiveMessage@@ -319,7 +322,7 @@           traverse_             (\(i :: Int) -> spawn $ foreverCheap               (void-                (  sendMessage (888888 + fromIntegral i) "test message"+                (  sendMessage (888888 + fromIntegral i) ("test message" :: String)                 >> yieldProcess                 )               )@@ -379,11 +382,11 @@               m <- receiveAnyMessage               void (sendAnyMessage me m)             )-          child2 <- spawn (foreverCheap (void (sendMessage 888888 "")))-          sendMessage child1 "test"+          child2 <- spawn (foreverCheap (void (sendMessage 888888 (""::String))))+          sendMessage child1 ("test" :: String)           i <- receiveMessage           sendInterrupt child2 testInterruptReason-          assertEff "" (i == "test")+          assertEff "" (i == ("test"::String))       , testCase "most processes send foreverCheap"       $ scheduleAndAssert schedulerFactory       $ \assertEff -> do@@ -391,7 +394,7 @@           traverse_             (\(i :: Int) -> spawn $ do               when (i `rem` 5 == 0) $ void $ sendMessage me i-              foreverCheap $ void (sendMessage 888 "test message to 888")+              foreverCheap $ void (sendMessage 888 ("test message to 888" :: String))             )             [0 .. n]           oks <- replicateM (length [0, 5 .. n]) receiveMessage@@ -429,7 +432,7 @@               when (i `rem` 5 == 0) $ void $ sendMessage me i               parent <- self               foreverCheap $ void-                (spawn (void (sendMessage parent "test msg from child")))+                (spawn (void (sendMessage parent ("test msg from child"::String))))             )             [0 .. n]           oks <- replicateM (length [0, 5 .. n]) receiveMessage@@ -485,11 +488,11 @@           [ ( "receiving"             , void               (send-                (ReceiveSelectedMessage @r (filterMessage (== "test message")))+                (ReceiveSelectedMessage @r (filterMessage (== ("test message" :: String))))               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn "test message")))+            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message" :: String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -517,11 +520,11 @@           [ ( "receiving"             , void               (send-                (ReceiveSelectedMessage @r (filterMessage (== "test message")))+                (ReceiveSelectedMessage @r (filterMessage (== ("test message"::String))))               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn "test message")))+            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message"::String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -563,11 +566,11 @@           [ ( "receiving"             , void               (send-                (ReceiveSelectedMessage @r (filterMessage (== "test message")))+                (ReceiveSelectedMessage @r (filterMessage (== ("test message"::String))))               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn "test message")))+            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message"::String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -627,12 +630,12 @@         me    <- self         other <- spawn           (do-            untilInterrupted (SendMessage @r 666666 (Dynamic.toDyn "test"))-            void (sendMessage me "OK")+            untilInterrupted (SendMessage @r 666666 (Dynamic.toDyn ("test"::String)))+            void (sendMessage me ("OK"::String))           )         void (sendInterrupt other testInterruptReason)         a <- receiveMessage-        assertEff "" (a == "OK")+        assertEff "" (a == ("OK"::String))     , testCase "while it is receiving"     $ scheduleAndAssert schedulerFactory     $ \assertEff -> do@@ -640,11 +643,11 @@         other <- spawn           (do             untilInterrupted (ReceiveSelectedMessage @r selectAnyMessageLazy)-            void (sendMessage me "OK")+            void (sendMessage me ("OK" :: String))           )         void (sendInterrupt other testInterruptReason)         a <- receiveMessage-        assertEff "" (a == "OK")+        assertEff "" (a == ("OK" :: String))     , testCase "while it is self'ing"     $ scheduleAndAssert schedulerFactory     $ \assertEff -> do@@ -652,10 +655,10 @@         other <- spawn           (do             untilInterrupted (SelfPid @r)-            void (sendMessage me "OK")+            void (sendMessage me ("OK" :: String))           )         void (sendInterrupt other (ProcessError "testError"))-        a <- receiveMessage+        (a :: String) <- receiveMessage         assertEff "" (a == "OK")     , testCase "while it is spawning"     $ scheduleAndAssert schedulerFactory@@ -664,11 +667,11 @@         other <- spawn           (do             untilInterrupted (Spawn @r (return ()))-            void (sendMessage me "OK")+            void (sendMessage me ("OK"::String))           )         void (sendInterrupt other testInterruptReason)         a <- receiveMessage-        assertEff "" (a == "OK")+        assertEff "" (a == ("OK"::String))     , testCase "while it is sending shutdown messages"     $ scheduleAndAssert schedulerFactory     $ \assertEff -> do@@ -676,11 +679,11 @@         other <- spawn           (do             untilInterrupted (SendShutdown @r 777 ExitNormally)-            void (sendMessage me "OK")+            void (sendMessage me ("OK"::String))           )         void (sendInterrupt other testInterruptReason)         a <- receiveMessage-        assertEff "" (a == "OK")+        assertEff "" (a == ("OK"::String))     , testCase "handleInterrupt handles my own interrupts"     $ scheduleAndAssert schedulerFactory     $ \assertEff ->@@ -817,17 +820,17 @@         foo2 foo1Pid = do           linkProcess foo1Pid           (r1, barPid) <- receiveMessage-          lift ("unlink foo1" @=? r1)+          lift (("unlink foo1" :: String) @=? r1)           unlinkProcess foo1Pid-          sendMessage barPid ("unlinked foo1", foo1Pid)-          receiveMessage >>= lift . (@?= "the end")+          sendMessage barPid ("unlinked foo1" :: String, foo1Pid)+          receiveMessage >>= lift . (@?= ("the end":: String))           exitWithError "foo two"         bar foo2Pid parentPid = do           linkProcess foo2Pid           me <- self-          sendMessage foo2Pid ("unlink foo1", me)+          sendMessage foo2Pid ("unlink foo1" :: String, me)           (r1, foo1Pid) <- receiveMessage-          lift ("unlinked foo1" @=? r1)+          lift (("unlinked foo1" :: String) @=? r1)           handleInterrupts             (const (return ()))             (do@@ -840,7 +843,7 @@               (sendMessage parentPid (LinkedProcessCrashed foo2Pid == er))             )             (do-              sendMessage foo2Pid "the end"+              sendMessage foo2Pid ("the end" :: String)               void receiveAnyMessage             )       foo1Pid <- spawn foo1@@ -966,7 +969,7 @@         me    <- self         other <- spawn           (do-            replicateM_ n $ sendMessage me "bad message"+            replicateM_ n $ sendMessage me ("bad message" :: String)             r <- receiveMessage @()             lift (r @?= ())             replicateM_ n $ sendMessage me testMsg

@@ -61,7 +61,7 @@                         void exitNormally                         error "This should not happen (child)!!"                     )-                sendMessage child (toDyn "test")+                sendMessage child (toDyn ("test" :: String))                 void exitNormally                 error "This should not happen!!"             )