diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/examples/example-1/Main.hs b/examples/example-1/Main.hs --- a/examples/example-1/Main.hs +++ b/examples/example-1/Main.hs @@ -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) diff --git a/examples/example-2/Main.hs b/examples/example-2/Main.hs --- a/examples/example-2/Main.hs +++ b/examples/example-2/Main.hs @@ -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 ) ) diff --git a/examples/example-3/Main.hs b/examples/example-3/Main.hs --- a/examples/example-3/Main.hs +++ b/examples/example-3/Main.hs @@ -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" diff --git a/examples/example-4/Main.hs b/examples/example-4/Main.hs --- a/examples/example-4/Main.hs +++ b/examples/example-4/Main.hs @@ -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) diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -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 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 diff --git a/src/Control/Eff/Concurrent.hs b/src/Control/Eff/Concurrent.hs --- a/src/Control/Eff/Concurrent.hs +++ b/src/Control/Eff/Concurrent.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Api/Observer/Queue.hs b/src/Control/Eff/Concurrent/Api/Observer/Queue.hs --- a/src/Control/Eff/Concurrent/Api/Observer/Queue.hs +++ b/src/Control/Eff/Concurrent/Api/Observer/Queue.hs @@ -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. diff --git a/src/Control/Eff/Concurrent/Api/Server.hs b/src/Control/Eff/Concurrent/Api/Server.hs --- a/src/Control/Eff/Concurrent/Api/Server.hs +++ b/src/Control/Eff/Concurrent/Api/Server.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Process.hs b/src/Control/Eff/Concurrent/Process.hs --- a/src/Control/Eff/Concurrent/Process.hs +++ b/src/Control/Eff/Concurrent/Process.hs @@ -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; diff --git a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs --- a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs @@ -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 () + ) diff --git a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs --- a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs @@ -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 diff --git a/src/Control/Eff/Log.hs b/src/Control/Eff/Log.hs --- a/src/Control/Eff/Log.hs +++ b/src/Control/Eff/Log.hs @@ -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" diff --git a/src/Control/Eff/Log/Channel.hs b/src/Control/Eff/Log/Channel.hs deleted file mode 100644 --- a/src/Control/Eff/Log/Channel.hs +++ /dev/null @@ -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 () - } diff --git a/src/Control/Eff/Log/Examples.hs b/src/Control/Eff/Log/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Examples.hs @@ -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 + ) diff --git a/src/Control/Eff/Log/Handler.hs b/src/Control/Eff/Log/Handler.hs --- a/src/Control/Eff/Log/Handler.hs +++ b/src/Control/Eff/Log/Handler.hs @@ -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)) diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs --- a/src/Control/Eff/Log/Message.hs +++ b/src/Control/Eff/Log/Message.hs @@ -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 diff --git a/src/Control/Eff/Log/MessageRenderer.hs b/src/Control/Eff/Log/MessageRenderer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/MessageRenderer.hs @@ -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 diff --git a/src/Control/Eff/Log/Writer.hs b/src/Control/Eff/Log/Writer.hs --- a/src/Control/Eff/Log/Writer.hs +++ b/src/Control/Eff/Log/Writer.hs @@ -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. diff --git a/src/Control/Eff/LogWriter/Async.hs b/src/Control/Eff/LogWriter/Async.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/Async.hs @@ -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 () + } diff --git a/src/Control/Eff/LogWriter/Capture.hs b/src/Control/Eff/LogWriter/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/Capture.hs @@ -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 diff --git a/src/Control/Eff/LogWriter/Console.hs b/src/Control/Eff/LogWriter/Console.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/Console.hs @@ -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) diff --git a/src/Control/Eff/LogWriter/DebugTrace.hs b/src/Control/Eff/LogWriter/DebugTrace.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/DebugTrace.hs @@ -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) diff --git a/src/Control/Eff/LogWriter/File.hs b/src/Control/Eff/LogWriter/File.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/File.hs @@ -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)) diff --git a/src/Control/Eff/LogWriter/IO.hs b/src/Control/Eff/LogWriter/IO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/IO.hs @@ -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 diff --git a/src/Control/Eff/LogWriter/UDP.hs b/src/Control/Eff/LogWriter/UDP.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/UDP.hs @@ -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 + ) diff --git a/src/Control/Eff/LogWriter/UnixSocket.hs b/src/Control/Eff/LogWriter/UnixSocket.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/LogWriter/UnixSocket.hs @@ -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 + ) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test/ForkIOScheduler.hs b/test/ForkIOScheduler.hs --- a/test/ForkIOScheduler.hs +++ b/test/ForkIOScheduler.hs @@ -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 () diff --git a/test/LogMessageIdeaTest.hs b/test/LogMessageIdeaTest.hs new file mode 100644 --- /dev/null +++ b/test/LogMessageIdeaTest.hs @@ -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 diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs --- a/test/LoggingTests.hs +++ b/test/LoggingTests.hs @@ -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") diff --git a/test/LoopTests.hs b/test/LoopTests.hs --- a/test/LoopTests.hs +++ b/test/LoopTests.hs @@ -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 ()) diff --git a/test/ProcessBehaviourTestCases.hs b/test/ProcessBehaviourTestCases.hs --- a/test/ProcessBehaviourTestCases.hs +++ b/test/ProcessBehaviourTestCases.hs @@ -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 diff --git a/test/SingleThreadedScheduler.hs b/test/SingleThreadedScheduler.hs --- a/test/SingleThreadedScheduler.hs +++ b/test/SingleThreadedScheduler.hs @@ -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!!" )