diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,17 @@ # Changelog for extensible-effects-concurrent + +## 0.6.0 + +- Rewrite Logging +- Improve Experimental Nix expressions + ## 0.5.0.0 - Switch to `extensible-effects` version `3.1.0.0` - Bump to stackage LTS-12.9 - Add `Control.Eff.Log.MessageFactory` -- Add `Control.Eff.Log.Syslog` +- Add `Control.Eff.Log.Message` ## 0.4.0.0 diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,12 +1,12 @@ name: extensible-effects-concurrent -version: 0.5.0.1 +version: 0.6.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 bug-reports: https://github.com/sheyll/extensible-effects-concurrent/issues -author: Sven Heyll +author: Sven Heyll maintainer: sven.heyll@gmail.com -category: Concurrency +category: Concurrency copyright: Copyright Sven Heyll license: BSD3 license-file: LICENSE @@ -57,8 +57,9 @@ Control.Eff.Loop, Control.Eff.ExceptionExtra, Control.Eff.Log, - Control.Eff.Log.Syslog, - Control.Eff.Log.MessageFactory, + Control.Eff.Log.Channel, + Control.Eff.Log.Handler, + Control.Eff.Log.Message, Control.Eff.Concurrent, Control.Eff.Concurrent.Api, Control.Eff.Concurrent.Api.Client, diff --git a/src/Control/Eff/Concurrent/Api/Observer.hs b/src/Control/Eff/Concurrent/Api/Observer.hs --- a/src/Control/Eff/Concurrent/Api/Observer.hs +++ b/src/Control/Eff/Concurrent/Api/Observer.hs @@ -22,21 +22,22 @@ , CallbackObserver , spawnCallbackObserver , spawnLoggingObserver - ) where + ) +where -import GHC.Stack -import Data.Dynamic -import Data.Set (Set) -import qualified Data.Set as Set -import Control.Eff -import Control.Eff.Concurrent.Process -import Control.Eff.Concurrent.Api -import Control.Eff.Concurrent.Api.Client -import Control.Eff.Concurrent.Api.Server -import Control.Eff.Log -import Control.Eff.State.Strict -import Control.Lens -import Control.Monad +import GHC.Stack +import Data.Dynamic +import Data.Set ( Set ) +import qualified Data.Set as Set +import Control.Eff +import Control.Eff.Concurrent.Process +import Control.Eff.Concurrent.Api +import Control.Eff.Concurrent.Api.Client +import Control.Eff.Concurrent.Api.Server +import Control.Eff.Log +import Control.Eff.State.Strict +import Control.Lens +import Control.Monad -- | An 'Api' index that support observation of the -- another 'Api' that is 'Observable'. @@ -57,30 +58,33 @@ forgetObserverMessage :: SomeObserver o -> Api o 'Asynchronous -- | Send an 'Observation' to an 'Observer' -notifyObserver :: ( SetMember Process (Process q) r - , Observable o - , Observer p o - , HasCallStack - ) - => SchedulerProxy q -> Server p -> Server o -> Observation o -> Eff r () +notifyObserver + :: (SetMember Process (Process q) r, Observable o, Observer p o, HasCallStack) + => SchedulerProxy q + -> Server p + -> Server o + -> Observation o + -> Eff r () notifyObserver px observer observed observation = cast px observer (observationMessage observed observation) -- | Send the 'registerObserverMessage' -registerObserver :: ( SetMember Process (Process q) r - , Observable o - , Observer p o - , HasCallStack - ) - => SchedulerProxy q -> Server p -> Server o -> Eff r () +registerObserver + :: (SetMember Process (Process q) r, Observable o, Observer p o, HasCallStack) + => SchedulerProxy q + -> Server p + -> Server o + -> Eff r () registerObserver px observer observed = cast px observed (registerObserverMessage (SomeObserver observer)) -- | Send the 'forgetObserverMessage' -forgetObserver :: ( SetMember Process (Process q) r - , Observable o - , Observer p o) - => SchedulerProxy q -> Server p -> Server o -> Eff r () +forgetObserver + :: (SetMember Process (Process q) r, Observable o, Observer p o) + => SchedulerProxy q + -> Server p + -> Server o + -> Eff r () forgetObserver px observer observed = cast px observed (forgetObserverMessage (SomeObserver observer)) @@ -101,15 +105,13 @@ o1 == o2 -- | Send an 'Observation' to 'SomeObserver'. -notifySomeObserver :: ( SetMember Process (Process q) r - , Observable o - , HasCallStack - ) - => SchedulerProxy q - -> Server o - -> Observation o - -> SomeObserver o - -> Eff r () +notifySomeObserver + :: (SetMember Process (Process q) r, Observable o, HasCallStack) + => SchedulerProxy q + -> Server o + -> Observation o + -> SomeObserver o + -> Eff r () notifySomeObserver px observed observation (SomeObserver observer) = notifyObserver px observer observed observation @@ -130,27 +132,34 @@ -- | Add an 'Observer' to the 'Observers' managed by 'manageObservers'. addObserver :: ( SetMember Process (Process q) r - , Member (State (Observers o)) r - , Observable o) - => SomeObserver o -> Eff r () + , Member (State (Observers o)) r + , Observable o + ) + => SomeObserver o + -> Eff r () addObserver = modify . over observers . Set.insert -- | Delete an 'Observer' from the 'Observers' managed by 'manageObservers'. removeObserver - :: ( SetMember Process (Process q) r - , Member (State (Observers o)) r - , Observable o) - => SomeObserver o -> Eff r () + :: ( SetMember Process (Process q) r + , Member (State (Observers o)) r + , Observable o + ) + => SomeObserver o + -> Eff r () removeObserver = modify . over observers . Set.delete -- | Send an 'Observation' to all 'SomeObserver's in the 'Observers' state. notifyObservers :: forall o r q - . ( Observable o - , SetMember Process (Process q) r - , Member (State (Observers o)) r) - => SchedulerProxy q -> Observation o -> Eff r () + . ( Observable o + , SetMember Process (Process q) r + , Member (State (Observers o)) r + ) + => SchedulerProxy q + -> Observation o + -> Eff r () notifyObservers px observation = do me <- asServer @o <$> self px os <- view observers <$> get @@ -173,29 +182,29 @@ -- | Start a new process for an 'Observer' that schedules -- all observations to an effectful callback. spawnCallbackObserver - :: forall o r q . - ( SetMember Process (Process q) r - , Typeable o - , Show (Observation o) - , Observable o - , Member (Logs String) q) + :: forall o r q + . ( SetMember Process (Process q) r + , Typeable o + , Show (Observation o) + , Observable o + , Member (Logs LogMessage) q + ) => SchedulerProxy q -> (Server o -> Observation o -> Eff (Process q ': q) Bool) -> Eff r (Server (CallbackObserver o)) spawnCallbackObserver px onObserve = asServer @(CallbackObserver o) - <$> - (spawn @r @q $ do - let loopUntil = - serve px - (ApiHandler @(CallbackObserver o) - (handleCast loopUntil) - (unhandledCallError px) - (defaultTermination px)) - loopUntil) + <$> (spawn @r @q $ do + let loopUntil = serve + px + (ApiHandler @(CallbackObserver o) (handleCast loopUntil) + (unhandledCallError px) + (defaultTermination px) + ) + loopUntil + ) where - handleCast k (CbObserved fromSvr v) = - onObserve fromSvr v >>= flip when k + handleCast k (CbObserved fromSvr v) = onObserve fromSvr v >>= flip when k -- | Use 'spawnCallbackObserver' to create a universal logging observer, -- using the 'Show' instance of the 'Observation'. @@ -204,14 +213,15 @@ -- -- @since 0.3.0.0 spawnLoggingObserver - :: forall o r q . - ( SetMember Process (Process q) r - , Typeable o - , Show (Observation o) - , Observable o - , Member (Logs String) q) + :: forall o r q + . ( SetMember Process (Process q) r + , Typeable o + , Show (Observation o) + , Observable o + , Member (Logs LogMessage) q + ) => SchedulerProxy q -> Eff r (Server (CallbackObserver o)) -spawnLoggingObserver px = - spawnCallbackObserver px - (\s o -> logMsg (show s ++ " OBSERVED: " ++ show o) >> return True) +spawnLoggingObserver px = spawnCallbackObserver + px + (\s o -> logDebug (show s ++ " OBSERVED: " ++ show o) >> return True) diff --git a/src/Control/Eff/Concurrent/Examples.hs b/src/Control/Eff/Concurrent/Examples.hs --- a/src/Control/Eff/Concurrent/Examples.hs +++ b/src/Control/Eff/Concurrent/Examples.hs @@ -1,13 +1,13 @@ -- | A complete example for the library module Control.Eff.Concurrent.Examples where -import GHC.Stack -import Control.Eff -import Control.Eff.Lift -import Control.Monad -import Data.Dynamic -import Control.Eff.Concurrent -import qualified Control.Exception as Exc +import GHC.Stack +import Control.Eff +import Control.Eff.Lift +import Control.Monad +import Data.Dynamic +import Control.Eff.Concurrent +import qualified Control.Exception as Exc data TestApi deriving Typeable @@ -30,100 +30,100 @@ main = defaultMain (example forkIoScheduler) mainProcessSpawnsAChildAndReturns - :: ( HasCallStack, SetMember Process (Process q) r) - => SchedulerProxy q -> Eff r () -mainProcessSpawnsAChildAndReturns px = - void (spawn (void (receiveMessage px))) + :: (HasCallStack, SetMember Process (Process q) r) + => SchedulerProxy q + -> Eff r () +mainProcessSpawnsAChildAndReturns px = void (spawn (void (receiveMessage px))) example :: ( HasCallStack - , SetMember Process (Process q) r - , Member (Logs String) r - , Member (Logs String) q - , SetMember Lift (Lift IO) q - , SetMember Lift (Lift IO) r) - => SchedulerProxy q -> Eff r () + , SetMember Process (Process q) r + , Member (Logs LogMessage) r + , Member (Logs LogMessage) q + , SetMember Lift (Lift IO) q + , SetMember Lift (Lift IO) r + ) + => SchedulerProxy q + -> Eff r () example px = do me <- self px - logMsg ("I am " ++ show me) + logInfo ("I am " ++ show me) server <- asServer @TestApi <$> spawn testServerLoop - logMsg ("Started server " ++ show server) + logInfo ("Started server " ++ show server) let go = do x <- lift getLine case x of - ('k':rest) -> do + ('k' : rest) -> do callRegistered px (TerminateError rest) go - ('s':_) -> do + ('s' : _) -> do callRegistered px Terminate go - ('c':_) -> do + ('c' : _) -> do castRegistered px (Shout x) go - ('r':rest) -> do - void (replicateM - (read rest) - (castRegistered px (Shout x))) + ('r' : rest) -> do + void (replicateM (read rest) (castRegistered px (Shout x))) go - ('q':_) -> - logMsg "Done." - _ -> - do res <- ignoreProcessError px (callRegistered px (SayHello x)) - logMsg ("Result: " ++ show res) - go + ('q' : _) -> logInfo "Done." + _ -> do + res <- ignoreProcessError px (callRegistered px (SayHello x)) + logInfo ("Result: " ++ show res) + go registerServer server go testServerLoop - :: forall r . - (HasCallStack - , Member (Logs String) r - , SetMember Lift (Lift IO) r) + :: forall r + . (HasCallStack, Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => Eff (Process r ': r) () -testServerLoop = - serve px $ ApiHandler handleCast handleCall handleTerminate - where - px :: SchedulerProxy r - px = SchedulerProxy - handleCast :: Api TestApi 'Asynchronous -> Eff (Process r ': r) () - handleCast (Shout x) = do - me <- self px - logMsg (show me ++ " Shouting: " ++ x) - handleCall :: Api TestApi ('Synchronous x) -> (x -> Eff (Process r ': r) ()) -> Eff (Process r ': r) () - handleCall (SayHello "e1") _reply = do - me <- self px - logMsg (show me ++ " raising an error") - raiseError px "No body loves me... :,(" - handleCall (SayHello "e2") _reply = do - me <- self px - logMsg (show me ++ " throwing a MyException ") - lift (Exc.throw MyException) - handleCall (SayHello "self") reply = do - me <- self px - logMsg (show me ++ " casting to self") - cast px (asServer @TestApi me) (Shout "from me") - void (reply False) - handleCall (SayHello "die") reply = do - me <- self px - logMsg (show me ++ " throwing and catching ") - catchRaisedError px - (\ er -> logMsg ("WOW: " ++ show er ++ " - No. This is wrong!")) - (raiseError px "No body loves me... :,(") - void (reply True) - handleCall (SayHello x) reply = do - me <- self px - logMsg (show me ++ " Got Hello: " ++ x) - void (reply (length x > 3)) - handleCall Terminate reply = do - me <- self px - logMsg (show me ++ " exiting") - void (reply ()) - exitNormally px - handleCall (TerminateError msg) reply = do - me <- self px - logMsg (show me ++ " exiting with error: " ++ msg) - void (reply ()) - exitWithError px msg - handleTerminate msg = do - me <- self px - logMsg (show me ++ " is exiting: " ++ show msg) - maybe (exitNormally px) (exitWithError px) msg +testServerLoop = serve px $ ApiHandler handleCast handleCall handleTerminate + where + px :: SchedulerProxy r + px = SchedulerProxy + handleCast :: Api TestApi 'Asynchronous -> Eff (Process r ': r) () + handleCast (Shout x) = do + me <- self px + logInfo (show me ++ " Shouting: " ++ x) + handleCall + :: Api TestApi ( 'Synchronous x) + -> (x -> Eff (Process r ': r) ()) + -> Eff (Process r ': r) () + handleCall (SayHello "e1") _reply = do + me <- self px + logInfo (show me ++ " raising an error") + raiseError px "No body loves me... :,(" + handleCall (SayHello "e2") _reply = do + me <- self px + logInfo (show me ++ " throwing a MyException ") + lift (Exc.throw MyException) + handleCall (SayHello "self") reply = do + me <- self px + logInfo (show me ++ " casting to self") + cast px (asServer @TestApi me) (Shout "from me") + void (reply False) + handleCall (SayHello "die") reply = do + me <- self px + logInfo (show me ++ " throwing and catching ") + catchRaisedError + px + (\er -> logInfo ("WOW: " ++ show er ++ " - No. This is wrong!")) + (raiseError px "No body loves me... :,(") + void (reply True) + handleCall (SayHello x) reply = do + me <- self px + logInfo (show me ++ " Got Hello: " ++ x) + void (reply (length x > 3)) + handleCall Terminate reply = do + me <- self px + logInfo (show me ++ " exiting") + void (reply ()) + exitNormally px + handleCall (TerminateError msg) reply = do + me <- self px + logInfo (show me ++ " exiting with error: " ++ msg) + void (reply ()) + exitWithError px msg + handleTerminate msg = do + me <- self px + logInfo (show me ++ " is exiting: " ++ show msg) + maybe (exitNormally px) (exitWithError px) msg diff --git a/src/Control/Eff/Concurrent/Examples2.hs b/src/Control/Eff/Concurrent/Examples2.hs --- a/src/Control/Eff/Concurrent/Examples2.hs +++ b/src/Control/Eff/Concurrent/Examples2.hs @@ -36,14 +36,14 @@ forgetObserverMessage = UnobserveCounter logCounterObservations - :: (SetMember Process (Process q) r, Member (Logs String) q) + :: (SetMember Process (Process q) r, Member (Logs LogMessage) q) => SchedulerProxy q -> Eff r (Server (CallbackObserver Counter)) logCounterObservations px = spawnCallbackObserver px (\fromSvr msg -> do me <- self px - logMsg (show me ++ " observed on: " ++ show fromSvr ++ ": " ++ show msg) + logInfo (show me ++ " observed on: " ++ show fromSvr ++ ": " ++ show msg) return True ) @@ -51,7 +51,7 @@ :: forall r q . ( Member (State (Observers Counter)) r , Member (State Integer) r - , Member (Logs String) r + , Member (Logs LogMessage) r , SetMember Process (Process q) r ) => SchedulerProxy q @@ -64,14 +64,14 @@ handleCast (ObserveCounter o) = addObserver o handleCast (UnobserveCounter o) = removeObserver o handleCast Inc = do - logMsg "Inc" + logInfo "Inc" modify (+ (1 :: Integer)) currentCount <- get notifyObservers px (CountChanged currentCount) handleCall :: Api Counter ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r () handleCall Cnt reply = do c <- get - logMsg ("Cnt is " ++ show c) + logInfo ("Cnt is " ++ show c) reply c -- * Second API @@ -87,7 +87,7 @@ pocketCalcHandler :: forall r q . ( Member (State Integer) r - , Member (Logs String) r + , Member (Logs LogMessage) r , SetMember Process (Process q) r ) => SchedulerProxy q @@ -98,21 +98,21 @@ where handleCast :: Api PocketCalc 'Asynchronous -> Eff r () handleCast (AAdd x) = do - logMsg ("AsyncAdd " ++ show x) + logInfo ("AsyncAdd " ++ show x) modify (+ x) c <- get @Integer - logMsg ("Accumulator is " ++ show c) + logInfo ("Accumulator is " ++ show c) handleCall :: Api PocketCalc ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r () handleCall (Add x) reply = do - logMsg ("Add " ++ show x) + logInfo ("Add " ++ show x) modify (+ x) c <- get - logMsg ("Accumulator is " ++ show c) + logInfo ("Accumulator is " ++ show c) reply c serverLoop :: forall r q - . (Member (Logs String) r, SetMember Process (Process q) r) + . (Member (Logs LogMessage) r, SetMember Process (Process q) r) => SchedulerProxy q -> Eff r () serverLoop px = evalState @Integer @@ -124,8 +124,8 @@ -- ** Counter client counterExample - :: ( Member (Logs String) r - , Member (Logs String) q + :: ( Member (Logs LogMessage) r + , Member (Logs LogMessage) q , SetMember Process (Process q) r ) => SchedulerProxy q @@ -133,7 +133,7 @@ counterExample px = do let cnt sv = do r <- call px sv Cnt - logMsg (show sv ++ " " ++ show r) + logInfo (show sv ++ " " ++ show r) pid1 <- spawn (serverLoop px) pid2 <- spawn (serverLoop px) let cntServer1 = asServer @Counter pid1 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 @@ -40,15 +40,18 @@ import Control.Eff.Lift import Control.Eff.Log import Control.Eff.Reader.Strict as Reader +import Control.Monad.Log ( runLoggingT ) import Control.Lens import Control.Monad ( when , void , join + , (>=>) ) import qualified Control.Monad.State as Mtl import Data.Dynamic import Data.Map ( Map ) import qualified Data.Map as Map +import Text.Printf import Data.String -- | Information about a process, needed to implement 'MessagePassing' and @@ -73,7 +76,7 @@ , _processTable :: Map ProcessId ProcessInfo , _threadIdTable :: Map ProcessId ThreadId , _schedulerShuttingDown :: Bool - , _logChannel :: LogChannel String + , _logChannel :: LogChannel LogMessage } makeLenses ''Scheduler @@ -107,14 +110,14 @@ -- See SchedulerIO type HasSchedulerIO r = ( HasCallStack , SetMember Lift (Lift IO) r - , Member (Logs String) r + , Member (Logs LogMessage) r , Member (Reader SchedulerVar) r) -- | The concrete list of 'Eff'ects for this scheduler implementation. -- See HasSchedulerIO type SchedulerIO = '[ Reader SchedulerVar - , Logs String + , Logs LogMessage , Lift IO ] @@ -125,15 +128,15 @@ -- | This is the main entry point to running a message passing concurrency -- application. This function takes a 'Process' on top of the 'SchedulerIO' -- effect and a 'LogChannel' for concurrent logging. -schedule :: Eff (ConsProcess SchedulerIO) () -> LogChannel String -> IO () +schedule :: Eff (ConsProcess SchedulerIO) () -> LogChannel LogMessage -> IO () schedule e logC = void $ withNewSchedulerState $ \schedulerStateVar -> do pidVar <- newEmptyTMVarIO scheduleProcessWithShutdownAction schedulerStateVar pidVar $ do mt <- lift myThreadId mp <- lift (atomically (readTMVar pidVar)) - logMsg (show mp ++ " main process started in thread " ++ show mt) + logInfo (show mp ++ " main process started in thread " ++ show mt) e - logMsg (show mp ++ " main process returned") + logInfo (show mp ++ " main process returned") where withNewSchedulerState :: (SchedulerVar -> IO a) -> IO a withNewSchedulerState mainProcessAction = do @@ -144,7 +147,7 @@ where myPid = 1 tearDownScheduler myTId v = do - logChannelPutIO logC (show myTId ++ " begin scheduler tear down") + logChannelPutIO logC (debugMessage "begin scheduler tear down") sch <- (atomically (do @@ -156,12 +159,13 @@ ) logChannelPutIO logC - ( show myTId - ++ " killing " - ++ let ts = (sch ^.. threadIdTable . traversed) - in if length ts > 100 - then show (length ts) ++ " threads" - else show ts + (debugMessage + ( "killing " + ++ let ts = (sch ^.. threadIdTable . traversed) + in if length ts > 100 + then show (length ts) ++ " threads" + else show ts + ) ) imapM_ (killProcThread myTId) (sch ^. threadIdTable) Concurrent.yield @@ -177,8 +181,7 @@ . to Map.null STM.check allThreadsDead ) - logChannelPutIO logC "all threads dead" - + logChannelPutIO logC (infoMessage "all threads dead") killProcThread myTId _pid tid = when (myTId /= tid) (killThread tid) @@ -187,18 +190,17 @@ defaultMain :: Eff (ConsProcess SchedulerIO) () -> IO () defaultMain c = runLoggingT (logChannelBracket 128 - (Just "~~~~~~ main process started") - (Just "====== main process exited") + (Just (infoMessage "main process started")) (schedule c) ) - (print :: String -> IO ()) + (printLogMessage :: LogMessage -> IO ()) -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMainWithLogChannel - :: LogChannel String -> Eff (ConsProcess SchedulerIO) () -> IO () + :: LogChannel LogMessage -> Eff (ConsProcess SchedulerIO) () -> IO () defaultMainWithLogChannel logC c = closeLogChannelAfter - (Just (fromString "====== main process exited")) + (Just (fromString "main process exited")) logC (schedule c logC) @@ -210,11 +212,10 @@ scheduleProcessWithShutdownAction schedulerVar pidVar procAction = do cleanupVar <- newEmptyTMVarIO logC <- getLogChannelIO schedulerVar - mTid <- myThreadId eeres <- Exc.try (runProcEffects cleanupVar logC) let eres = join eeres - getAndExecCleanup cleanupVar eres logC mTid - logChannelPutIO logC (show mTid ++ " <~< process cleanup finished") + getAndExecCleanup cleanupVar eres logC + logChannelPutIO logC =<< debugMessageIO "process cleanup finished" return eres where @@ -241,37 +242,44 @@ STM.putTMVar pidVar pid ) ) - mTid <- lift myThreadId - logMsg (show mTid ++ " >~> begin process " ++ show pid) - procAction - getAndExecCleanup cleanupVar eres lc mt = do + interceptLogging + (logMsg . over lmMessage (printf "[PID %7i] %s" (toInteger pid))) + $ do + logDebug "begin process" + procAction + getAndExecCleanup cleanupVar eres lc = do mcleanup <- atomically (STM.tryTakeTMVar cleanupVar) traverse_ execCleanup mcleanup where execCleanup ca = do runCleanUpAction ca - logChannelPutIO lc $ show mt ++ case eres of + logChannelPutIO lc =<< case eres of Left se -> case Exc.fromException se of - Nothing -> " process caught exception: " ++ Exc.displayException se - Just schedulerErr -> - (case schedulerErr of - ProcessShuttingDown -> " process shutdown" - ProcessExitError m -> " process exited with error: " ++ show m - ProcessRaisedError m -> " process raised error: " ++ show m - _ -> " scheduler error: " ++ show schedulerErr - ) - ++ " - full exception message: " - ++ Exc.displayException se - - Right _ -> " process function returned" + Nothing -> errorMessageIO + ("process caught exception: " ++ Exc.displayException se) + Just schedulerErr + -> let exceptionMsg = + " - full exception message: " ++ Exc.displayException se + in + case schedulerErr of + ProcessShuttingDown -> debugMessageIO "process shutdown" + ProcessExitError m -> errorMessageIO + ("process exited with error: " ++ show m ++ exceptionMsg) + ProcessRaisedError m -> errorMessageIO + ("process raised error: " ++ show m ++ exceptionMsg) + _ -> + errorMessageIO + ("scheduler error: " ++ show schedulerErr ++ exceptionMsg + ) + Right _ -> debugMessageIO "process function returned" -getLogChannel :: HasSchedulerIO r => Eff r (LogChannel String) +getLogChannel :: HasSchedulerIO r => Eff r (LogChannel LogMessage) getLogChannel = do s <- getSchedulerVar lift (getLogChannelIO s) -getLogChannelIO :: SchedulerVar -> IO (LogChannel String) +getLogChannelIO :: SchedulerVar -> IO (LogChannel LogMessage) getLogChannelIO s = view logChannel <$> readTVarIO (fromSchedulerVar s) overProcessInfo @@ -432,7 +440,7 @@ ShutdownAction (forall a . Either SchedulerError () -> IO a) invokeShutdownAction - :: (HasCallStack, SetMember Lift (Lift IO) r, Member (Logs String) r) + :: (HasCallStack, SetMember Lift (Lift IO) r, Member (Logs LogMessage) r) => ShutdownAction -> Either SchedulerError () -> Eff r a @@ -488,13 +496,16 @@ (return . (maybe (show pid) show)) case didWork of - Right (_pinfo, True) -> return () - Right (pinfo, False) -> - logChannelPutIO lc ("queue already destroyed: " ++ show pinfo) + Right (_pinfo, True ) -> return () + Right (pinfo , False) -> logChannelPutIO lc + =<< errorMessageIO ("queue already destroyed: " ++ show pinfo) Left (e :: Exc.SomeException) -> getCause - >>= logChannelPutIO lc - . (("failed to destroy queue: " ++ show e ++ " ") ++) + >>= ( ( errorMessageIO + . (("failed to destroy queue: " ++ show e ++ " ") ++) + ) + >=> logChannelPutIO lc + ) overScheduler 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 @@ -21,7 +21,9 @@ import Control.Lens hiding ( (|>) , Empty ) -import Control.Monad ( void ) +import Control.Monad ( void + , (>=>) + ) import Control.Monad.IO.Class import qualified Data.Sequence as Seq import Data.Sequence ( Seq(..) ) @@ -72,7 +74,7 @@ => (l -> m ()) -> Eff (ConsProcess '[Logs l, Lift m]) a -> m (Either String a) -scheduleIOWithLogging handleLog = scheduleIO (handleLogsWith handleLog) +scheduleIOWithLogging handleLog = scheduleIO (handleLogsLifted handleLog) -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. -- @@ -262,7 +264,7 @@ -- | The concrete list of 'Eff'ects for running this pure scheduler on @IO@ and -- with string logging. type LoggingAndIo = - '[ Logs String + '[ Logs LogMessage , Lift IO ] @@ -274,8 +276,10 @@ -- @String@ effects. defaultMain :: HasCallStack - => Eff '[Process '[Logs String, Lift IO], Logs String, Lift IO] () + => Eff '[Process '[Logs LogMessage, Lift IO], Logs LogMessage, Lift IO] () -> IO () -defaultMain e = void $ runLift $ handleLogsWithLoggingTHandler - (scheduleMonadIOEff e) - ($! putStrLn) +defaultMain = + void + . runLift + . handleLogsWithLoggingTHandler ($ printLogMessage) + . scheduleMonadIOEff 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 @@ -1,337 +1,11 @@ -- | A logging effect based on 'Control.Monad.Log.MonadLog'. module Control.Eff.Log - ( - -- * Logging Effect - Logs(..) - , logMsg - , interceptLogging - , foldLogMessages - , module ExtLog - , captureLogs - , ignoreLogs - , handleLogsWith - , handleLogsWithLoggingTHandler - -- * Concurrent Logging - , LogChannel() - , logToChannel - , noLogger - , forkLogger - , filterLogChannel - , joinLogChannel - , killLogChannel - , closeLogChannelAfter - , logChannelBracket - , logChannelPutIO - -- ** Internals - , JoinLogChannelException() - , KillLogChannelException() + ( module Control.Eff.Log.Handler + , module Control.Eff.Log.Channel + , module Control.Eff.Log.Message ) where -import Control.Concurrent -import Control.Concurrent.STM -import Control.DeepSeq -import Control.Eff as Eff -import Control.Eff.Extend as Eff -import Control.Exception ( bracket ) -import qualified Control.Exception as Exc -import Control.Monad ( void - , when - , unless - ) -import Control.Monad.Log as ExtLog - hiding ( ) -import Control.Monad.Trans.Control -import qualified Control.Eff.Lift as Eff -import qualified Control.Monad.Log as Log -import Data.Foldable ( traverse_ ) -import Data.Kind ( ) -import Data.Sequence ( Seq() ) -import qualified Data.Sequence as Seq -import Data.String -import Data.Typeable - - - --- | Logging effect type, parameterized by a log message type. -data Logs message a where - LogMsg :: message -> Logs message () - --- | Log a message. -logMsg :: Member (Logs m) r => m -> Eff r () -logMsg msg = send (LogMsg msg) - --- | Change, add or remove log messages and perform arbitrary actions upon --- intercepting a log message. --- --- Requirements: --- --- * All log meta data for typical prod code can be added without --- changing much of the code --- --- * Add timestamp to a log messages of a sub-computation. --- --- * Write some messages to a file. --- --- * Log something extra, e.g. runtime memory usage in load tests --- --- Approach: Install a callback that sneaks into to log message --- sending/receiving, to intercept the messages and execute some code and then --- return a new message. -interceptLogging - :: forall r m a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a -interceptLogging interceptor = interpose return go - where - go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y - go (LogMsg m) k = do - interceptor m - k () - --- | Intercept logging to change, add or remove log messages. --- --- This is without side effects, hence faster than 'interceptLogging'. -foldLogMessages - :: forall r m a f - . (Foldable f, Member (Logs m) r) - => (m -> f m) - -> Eff r a - -> Eff r a -foldLogMessages interceptor = interpose return go - where - go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y - go (LogMsg m) k = do - traverse_ logMsg (interceptor m) - k () - --- | Capture all log messages in a 'Seq' (strict). -captureLogs - :: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message) -captureLogs = Eff.handle_relay_s Seq.empty - (\logs result -> return (result, logs)) - handleLogs - where - handleLogs - :: NFData message - => Seq message - -> Logs message x - -> (Seq message -> Arr r x y) - -> Eff r y - handleLogs !logs (LogMsg !m) k = k (force (logs Seq.:|> m)) () - --- | Throw away all log messages. -ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a -ignoreLogs = Eff.handle_relay return handleLogs - where - handleLogs :: Logs m x -> Arr r x y -> Eff r y - handleLogs (LogMsg _) k = k () - --- | Handle the 'Logs' effect with a monadic call back function (strict). -handleLogsWith - :: forall m r message a - . (NFData message, Monad m, SetMember Eff.Lift (Eff.Lift m) r) - => (message -> m ()) - -> Eff (Logs message ': r) a - -> Eff r a -handleLogsWith logMessageHandler = Eff.handle_relay return go - where - go :: Logs message b -> (b -> Eff r c) -> Eff r c - go (LogMsg m) k = do - res <- Eff.lift (logMessageHandler (force m)) - k res - --- | Handle the 'Logs' effect using 'Log.LoggingT' 'Log.Handler's. -handleLogsWithLoggingTHandler - :: forall m r message a - . (Monad m, SetMember Eff.Lift (Eff.Lift m) r) - => Eff (Logs message ': r) a - -> (forall b . (Log.Handler m message -> m b) -> m b) - -> Eff r a -handleLogsWithLoggingTHandler actionThatLogs foldHandler = Eff.handle_relay - return - go - actionThatLogs - where - go :: Logs message b -> (b -> Eff r c) -> Eff r c - go (LogMsg m) k = Eff.lift (foldHandler (\doLog -> doLog m)) >>= k - --- | A log channel processes logs from the 'Logs' effect by en-queuing them in a --- shared queue read from a seperate processes. A channel can contain log --- message filters. -data LogChannel message = - FilteredLogChannel (message -> Bool) (LogChannel message) - -- ^ filter log messages - | DiscardLogs - -- ^ discard all log messages - | ConcurrentLogChannel - { fromLogChannel :: TBQueue message - , _logChannelThread :: ThreadId - } - -- ^ send all log messages to a log process - --- | Send the log messages to a 'LogChannel'. -logToChannel - :: forall r message a - . (SetMember Eff.Lift (Eff.Lift IO) r) - => LogChannel message - -> Eff (Logs message ': r) a - -> Eff r a -logToChannel logChan actionThatLogs = handleLogsWithLoggingTHandler - actionThatLogs - (\withHandler -> withHandler (logChannelPutIO logChan)) - --- | Enqueue a log message into a log channel -logChannelPutIO :: LogChannel message -> message -> IO () -logChannelPutIO DiscardLogs _ = return () -logChannelPutIO (FilteredLogChannel f lc) m = when (f m) (logChannelPutIO lc m) -logChannelPutIO c m = atomically $ do - dropMessage <- isFullTBQueue (fromLogChannel c) - unless dropMessage (writeTBQueue (fromLogChannel c) m) - --- | Create a 'LogChannel' that will discard all messages sent --- via 'forwardLogstochannel' or 'logChannelPutIO'. -noLogger :: LogChannel message -noLogger = DiscardLogs - --- | Fork a new process, that applies a monadic action to all log messages sent --- via 'logToChannel' or 'logChannelPutIO'. -forkLogger - :: forall message - . (Typeable message, Show message) - => Int -- ^ Size of the log message input queue. If the queue is full, message - -- are dropped silently. - -> (message -> IO ()) -- ^ An IO action to log the messages - -> Maybe message -- ^ Optional __first__ message to log - -> IO (LogChannel message) -forkLogger queueLen handle mFirstMsg = do - msgQ <- atomically - (do - tq <- newTBQueue (fromIntegral @Int queueLen) - mapM_ (writeTBQueue tq) mFirstMsg - return tq - ) - thread <- forkFinally (logLoop msgQ) (writeLastLogs msgQ) - return (ConcurrentLogChannel msgQ thread) - where - writeLastLogs :: TBQueue message -> Either Exc.SomeException () -> IO () - writeLastLogs tq ee = do - logMessages <- atomically $ flushTBQueue tq - case ee of - Right _ -> return () - Left se -> case Exc.fromException se of - Just (JoinLogChannelException mCloseMsg) -> do - traverse_ handle logMessages - traverse_ handle mCloseMsg - Nothing -> case Exc.fromException se of - Just (KillLogChannelException mCloseMsg) -> - traverse_ handle mCloseMsg - Nothing -> mapM_ handle logMessages - - logLoop :: TBQueue message -> IO () - logLoop tq = do - m <- atomically $ readTBQueue tq - handle m - logLoop tq - --- | Filter logs sent to a 'LogChannel' using a predicate. -filterLogChannel - :: (message -> Bool) -> LogChannel message -> LogChannel message -filterLogChannel = FilteredLogChannel - --- | Run an action and close a 'LogChannel' created by 'noLogger', 'forkLogger' --- or 'filterLogChannel' afterwards using 'joinLogChannel'. If a --- 'Exc.SomeException' was thrown, the log channel is killed with --- 'killLogChannel', and the exception is re-thrown. -closeLogChannelAfter - :: (Show message, Typeable message, IsString message) - => Maybe message - -> LogChannel message - -> IO a - -> IO a -closeLogChannelAfter mGoodbye logC ioAction = do - res <- closeLogAndRethrow `Exc.handle` ioAction - closeLogSuccess - return res - where - closeLogAndRethrow :: Exc.SomeException -> IO a - closeLogAndRethrow se = do - let closeMsg = Just (fromString (Exc.displayException se)) - void $ Exc.try @Exc.SomeException $ killLogChannel closeMsg logC - Exc.throw se - - closeLogSuccess :: IO () - closeLogSuccess = joinLogChannel mGoodbye logC - --- | Close a log channel created by e.g. 'forkLogger'. Message already enqueue --- are handled, as well as an optional final message. Subsequent log message --- will not be handled anymore. If the log channel must be closed immediately, --- use 'killLogChannel' instead. -joinLogChannel - :: (Show message, Typeable message) - => Maybe message - -> LogChannel message - -> IO () -joinLogChannel _closeLogMessage DiscardLogs = return () -joinLogChannel Nothing (FilteredLogChannel _f lc) = joinLogChannel Nothing lc -joinLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) = - if f closeLogMessage - then joinLogChannel (Just closeLogMessage) lc - else joinLogChannel Nothing lc -joinLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) = - throwTo thread (JoinLogChannelException closeLogMessage) - --- | Close a log channel quickly, without logging messages already in the queue. --- Subsequent logging requests will not be handled anymore. If the log channel --- must be closed without loosing any messages, use 'joinLogChannel' instead. -killLogChannel - :: (Show message, Typeable message) - => Maybe message - -> LogChannel message - -> IO () -killLogChannel _closeLogMessage DiscardLogs = return () -killLogChannel Nothing (FilteredLogChannel _f lc) = killLogChannel Nothing lc -killLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) = - if f closeLogMessage - then killLogChannel (Just closeLogMessage) lc - else killLogChannel Nothing lc -killLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) = - throwTo thread (KillLogChannelException closeLogMessage) - --- | Internal exception to shutdown a 'LogChannel' process created by --- 'forkLogger'. This exception is handled such that all message already --- en-queued are handled and then an optional final message is written. -newtype JoinLogChannelException m = JoinLogChannelException (Maybe m) - deriving (Show, Typeable) - -instance (Typeable m, Show m) => Exc.Exception (JoinLogChannelException m) - --- | Internal exception to **immediately** shutdown a 'LogChannel' process --- created by 'forkLogger', other than 'JoinLogChannelException' the message queue --- will not be flushed, not further messages will be logged, except for the --- optional final message. -newtype KillLogChannelException m = KillLogChannelException (Maybe m) - deriving (Show, Typeable) - -instance (Typeable m, Show m) => Exc.Exception (KillLogChannelException m) - --- | Wrap 'LogChannel' creation and destruction around a monad action in --- 'bracket'y manner. This function uses 'joinLogChannel', so en-queued messages --- are flushed on exit. The resulting action is a 'LoggingT' action, which --- is essentially a reader for a log handler function in 'IO'. -logChannelBracket - :: (Show message, Typeable message) - => Int -- ^ Size of the log message input queue. If the queue is full, message - -- are dropped silently. - -> Maybe message -- ^ Optional __first__ message to log - -> Maybe message -- ^ Optional __last__ message to log - -> (LogChannel message -> IO a) -- ^ An IO action that will use the - -- 'LogChannel', after the action returns (even - -- because of an exception) the log channel is - -- destroyed. - -> LoggingT message IO a -logChannelBracket queueLen mWelcome mGoodbye f = control - (\runInIO -> do - let logHandler = void . runInIO . logMessage - bracket (forkLogger queueLen logHandler mWelcome) - (joinLogChannel mGoodbye) - f - ) +import Control.Eff.Log.Handler +import Control.Eff.Log.Channel +import Control.Eff.Log.Message diff --git a/src/Control/Eff/Log/Channel.hs b/src/Control/Eff/Log/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Channel.hs @@ -0,0 +1,193 @@ +-- | Concurrent Logging +module Control.Eff.Log.Channel + ( LogChannel() + , logToChannel + , noLogger + , forkLogger + , filterLogChannel + , joinLogChannel + , killLogChannel + , closeLogChannelAfter + , logChannelBracket + , logChannelPutIO + , JoinLogChannelException() + , KillLogChannelException() + ) +where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Eff as Eff +import Control.Exception ( bracket ) +import qualified Control.Exception as Exc +import Control.Monad ( void + , when + , unless + ) +import Control.Monad.Log as ExtLog + hiding ( ) +import Control.Monad.Trans.Control +import Control.Eff.Log.Handler +import qualified Control.Eff.Lift as Eff +import Data.Foldable ( traverse_ ) +import Data.Kind ( ) +import Data.String +import Data.Typeable + +-- | A log channel processes logs from the 'Logs' effect by en-queuing them in a +-- shared queue read from a seperate processes. A channel can contain log +-- message filters. +data LogChannel message = + FilteredLogChannel (message -> Bool) (LogChannel message) + -- ^ filter log messages + | DiscardLogs + -- ^ discard all log messages + | ConcurrentLogChannel + { fromLogChannel :: TBQueue message + , _logChannelThread :: ThreadId + } + -- ^ send all log messages to a log process + +-- | Send the log messages to a 'LogChannel'. +logToChannel + :: forall r message a + . (SetMember Eff.Lift (Eff.Lift IO) r) + => LogChannel message + -> Eff (Logs message ': r) a + -> Eff r a +logToChannel logChan = + handleLogsWithLoggingTHandler ($ logChannelPutIO logChan) + +-- | Enqueue a log message into a log channel +logChannelPutIO :: LogChannel message -> message -> IO () +logChannelPutIO DiscardLogs _ = return () +logChannelPutIO (FilteredLogChannel f lc) m = when (f m) (logChannelPutIO lc m) +logChannelPutIO c m = atomically $ do + dropMessage <- isFullTBQueue (fromLogChannel c) + unless dropMessage (writeTBQueue (fromLogChannel c) m) + +-- | Create a 'LogChannel' that will discard all messages sent +-- via 'forwardLogstochannel' or 'logChannelPutIO'. +noLogger :: LogChannel message +noLogger = DiscardLogs + +-- | Fork a new process, that applies a monadic action to all log messages sent +-- via 'logToChannel' or 'logChannelPutIO'. +forkLogger + :: forall message + . (Typeable message) + => Int -- ^ Size of the log message input queue. If the queue is full, message + -- are dropped silently. + -> (message -> IO ()) -- ^ An IO action to log the messages + -> Maybe message -- ^ Optional __first__ message to log + -> IO (LogChannel message) +forkLogger queueLen handle mFirstMsg = do + msgQ <- atomically + (do + tq <- newTBQueue (fromIntegral @Int queueLen) + mapM_ (writeTBQueue tq) mFirstMsg + return tq + ) + thread <- forkFinally (logLoop msgQ) (writeLastLogs msgQ) + return (ConcurrentLogChannel msgQ thread) + where + writeLastLogs :: TBQueue message -> Either Exc.SomeException () -> IO () + writeLastLogs tq ee = do + logMessages <- atomically $ flushTBQueue tq + case ee of + Right _ -> return () + Left se -> case Exc.fromException se of + Just JoinLogChannelException -> traverse_ handle logMessages + Nothing -> case Exc.fromException se of + Just KillLogChannelException -> return () + Nothing -> mapM_ handle logMessages + + logLoop :: TBQueue message -> IO () + logLoop tq = do + m <- atomically $ readTBQueue tq + handle m + logLoop tq + +-- | Filter logs sent to a 'LogChannel' using a predicate. +filterLogChannel + :: (message -> Bool) -> LogChannel message -> LogChannel message +filterLogChannel = FilteredLogChannel + +-- | Run an action and close a 'LogChannel' created by 'noLogger', 'forkLogger' +-- or 'filterLogChannel' afterwards using 'joinLogChannel'. If a +-- 'Exc.SomeException' was thrown, the log channel is killed with +-- 'killLogChannel', and the exception is re-thrown. +closeLogChannelAfter + :: (Typeable message, IsString message) + => Maybe message + -> LogChannel message + -> IO a + -> IO a +closeLogChannelAfter mGoodbye logC ioAction = do + res <- closeLogAndRethrow `Exc.handle` ioAction + closeLogSuccess + return res + where + closeLogAndRethrow :: Exc.SomeException -> IO a + closeLogAndRethrow se = do + void $ Exc.try @Exc.SomeException $ killLogChannel logC + Exc.throw se + + closeLogSuccess :: IO () + closeLogSuccess = joinLogChannel logC + +-- | Close a log channel created by e.g. 'forkLogger'. Message already enqueue +-- are handled. Subsequent log message +-- will not be handled anymore. If the log channel must be closed immediately, +-- use 'killLogChannel' instead. +joinLogChannel :: (Typeable message) => LogChannel message -> IO () +joinLogChannel DiscardLogs = return () +joinLogChannel (FilteredLogChannel _f lc) = joinLogChannel lc +joinLogChannel (ConcurrentLogChannel _tq thread) = + throwTo thread JoinLogChannelException + +-- | Close a log channel quickly, without logging messages already in the queue. +-- Subsequent logging requests will not be handled anymore. If the log channel +-- must be closed without loosing any messages, use 'joinLogChannel' instead. +killLogChannel :: (Typeable message) => LogChannel message -> IO () +killLogChannel DiscardLogs = return () +killLogChannel (FilteredLogChannel _f lc) = killLogChannel lc +killLogChannel (ConcurrentLogChannel _tq thread) = + throwTo thread KillLogChannelException + +-- | Internal exception to shutdown a 'LogChannel' process created by +-- 'forkLogger'. This exception is handled such that all message already +-- en-queued are handled and then an optional final message is written. +data JoinLogChannelException = JoinLogChannelException + deriving (Show, Typeable) + +instance Exc.Exception JoinLogChannelException + +-- | Internal exception to **immediately** shutdown a 'LogChannel' process +-- created by 'forkLogger', other than 'JoinLogChannelException' the message queue +-- will not be flushed, not further messages will be logged, except for the +-- optional final message. +data KillLogChannelException = KillLogChannelException + deriving (Show, Typeable) + +instance Exc.Exception KillLogChannelException + +-- | Wrap 'LogChannel' creation and destruction around a monad action in +-- 'bracket'y manner. This function uses 'joinLogChannel', so en-queued messages +-- are flushed on exit. The resulting action is a 'LoggingT' action, which +-- is essentially a reader for a log handler function in 'IO'. +logChannelBracket + :: (Typeable message) + => Int -- ^ Size of the log message input queue. If the queue is full, message + -- are dropped silently. + -> Maybe message -- ^ Optional __first__ message to log + -> (LogChannel message -> IO a) -- ^ An IO action that will use the + -- 'LogChannel', after the action returns (even + -- because of an exception) the log channel is + -- destroyed. + -> LoggingT message IO a +logChannelBracket queueLen mWelcome f = control + (\runInIO -> do + let logHandler = void . runInIO . logMessage + bracket (forkLogger queueLen logHandler mWelcome) joinLogChannel f + ) diff --git a/src/Control/Eff/Log/Handler.hs b/src/Control/Eff/Log/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Handler.hs @@ -0,0 +1,137 @@ +-- | A logging effect based on 'Control.Monad.Log.MonadLog'. +module Control.Eff.Log.Handler + ( + -- * Logging Effect + Logs(..) + , logMsg + , interceptLogging + , foldLogMessages + , relogAsString + , captureLogs + , ignoreLogs + , handleLogsWith + , handleLogsLifted + , handleLogsWithLoggingTHandler + ) +where + +import Control.DeepSeq +import Control.Eff as Eff +import Control.Eff.Extend as Eff +import qualified Control.Eff.Lift as Eff +import qualified Control.Monad.Log as Log +import Data.Foldable ( traverse_ ) +import Data.Kind ( ) +import Data.Sequence ( Seq() ) +import qualified Data.Sequence as Seq + +-- | Logging effect type, parameterized by a log message type. +data Logs message a where + LogMsg :: message -> Logs message () + +-- | Log a message. +logMsg :: Member (Logs m) r => m -> Eff r () +logMsg = send . LogMsg + +-- | Change, add or remove log messages and perform arbitrary actions upon +-- intercepting a log message. +-- +-- Requirements: +-- +-- * All log meta data for typical prod code can be added without +-- changing much of the code +-- +-- * Add timestamp to a log messages of a sub-computation. +-- +-- * Write some messages to a file. +-- +-- * Log something extra, e.g. runtime memory usage in load tests +-- +-- Approach: Install a callback that sneaks into to log message +-- sending/receiving, to intercept the messages and execute some code and then +-- return a new message. +interceptLogging + :: forall r m a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a +interceptLogging interceptor = interpose return go + where + go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y + go (LogMsg m) k = do + interceptor m + k () + +-- | Intercept logging to change, add or remove log messages. +-- +-- This is without side effects, hence faster than 'interceptLogging'. +foldLogMessages + :: forall r m a f + . (Foldable f, Member (Logs m) r) + => (m -> f m) + -> Eff r a + -> Eff r a +foldLogMessages interceptor = interpose return go + where + go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y + go (LogMsg m) k = do + traverse_ logMsg (interceptor m) + k () + +-- | Capture all log messages in a 'Seq' (strict). +captureLogs + :: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message) +captureLogs = Eff.handle_relay_s Seq.empty + (\logs result -> return (result, logs)) + handleLogs + where + handleLogs + :: NFData message + => Seq message + -> Logs message x + -> (Seq message -> Arr r x y) + -> Eff r y + handleLogs !logs (LogMsg !m) k = k (force (logs Seq.:|> m)) () + +-- | Throw away all log messages. +ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a +ignoreLogs = Eff.handle_relay return handleLogs + where + handleLogs :: Logs m x -> Arr r x y -> Eff r y + handleLogs (LogMsg _) k = k () + +-- | Handle a 'Logs' effect with a message that has a 'Show' instance by +-- **re-logging** each message applied to 'show'. +relogAsString + :: forall m e a + . (Show m, Member (Logs String) e) + => Eff (Logs m ': e) a + -> Eff e a +relogAsString = handleLogsWith (logMsg . show) + +-- | Apply a function that returns an effect to each log message. +handleLogsWith + :: forall message e a + . (message -> Eff e ()) + -> Eff (Logs message ': e) a + -> Eff e a +handleLogsWith h = handle_relay return $ \(LogMsg m) k -> h m >>= k + +-- | Handle the 'Logs' effect with a monadic call back function (strict). +handleLogsLifted + :: forall m r message a + . (NFData message, Monad m, SetMember Eff.Lift (Eff.Lift m) r) + => (message -> m ()) + -> Eff (Logs message ': r) a + -> Eff r a +handleLogsLifted logMessageHandler = handleLogsWith go + where + go :: message -> Eff r () + go m = Eff.lift (logMessageHandler (force m)) + +-- | Handle the 'Logs' effect using 'Log.LoggingT' 'Log.Handler's. +handleLogsWithLoggingTHandler + :: forall m r message a + . (Monad m, SetMember Eff.Lift (Eff.Lift m) r) + => (forall b . (Log.Handler m message -> m b) -> m b) + -> Eff (Logs message ': r) a + -> Eff r a +handleLogsWithLoggingTHandler foldHandler = + handleLogsWith (Eff.lift . foldHandler . flip ($)) diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Message.hs @@ -0,0 +1,421 @@ +-- | An RFC 5434 inspired log message and convenience functions for +-- logging them. +module Control.Eff.Log.Message + ( LogMessage(..) + , renderRFC5424 + , printLogMessage + , relogAsDebugMessages + , logWithSeverity + , logEmergency + , logAlert + , logCritical + , logError + , logWarning + , logNotice + , logInfo + , logDebug + , errorMessage + , infoMessage + , debugMessage + , errorMessageIO + , infoMessageIO + , debugMessageIO + , Severity(fromSeverity) + , emergencySeverity + , alertSeverity + , criticalSeverity + , errorSeverity + , warningSeverity + , noticeSeverity + , informationalSeverity + , debugSeverity + , Facility(fromFacility) + , kernelMessages + , userLevelMessages + , mailSystem + , systemDaemons + , securityAuthorizationMessages4 + , linePrinterSubsystem + , networkNewsSubsystem + , uucpSubsystem + , clockDaemon + , securityAuthorizationMessages10 + , ftpDaemon + , ntpSubsystem + , logAuditFacility + , logAlertFacility + , clockDaemon2 + , local0 + , local1 + , local2 + , local3 + , local4 + , local5 + , local6 + , local7 + , lmFacility + , lmSeverity + , lmTimestamp + , lmHostname + , lmAppname + , lmProcessId + , lmMessageId + , lmStructuredData + , lmSrcLoc + , lmThreadId + , lmMessage + , setCallStack + , StructuredDataElement(..) + , sdElementId + , sdElementParameters + ) +where + +import Data.Time.Clock +import Data.Time.Format +import Control.Lens +import Control.Eff +import Control.Eff.Log.Handler +import GHC.Stack +import Data.Default +import Control.DeepSeq +import Control.Monad.IO.Class +import Data.Maybe +import Data.String +import Control.Concurrent +import GHC.Generics +import Text.Printf +import Control.Monad ( (>=>) ) + +-- | A message data type inspired by the RFC-5424 Syslog Protocol +data LogMessage = + LogMessage { _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} + deriving (Eq, Generic) + +showLmMessage :: LogMessage -> [String] +showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) = + if null msg + then [] + else + maybe "" (printf "[%s]" . show) ti + : msg + : maybe [] (pure . prettySrcLoc) loc + + +-- | Render a 'LogMessage' human readable. +renderLogMessage :: LogMessage -> String +renderLogMessage l@(LogMessage _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@(LogMessage 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 + ) + + +instance NFData LogMessage + +-- | RFC-5424 defines how structured data can be included in a log message. +data StructuredDataElement = + SdElement { _sdElementId :: String + , _sdElementParameters :: [SdParameter]} + deriving (Eq, Ord, Generic) + +instance Show StructuredDataElement where + show (SdElement sdid params) = + "[" ++ sdName sdid ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]" + +instance NFData StructuredDataElement + +-- | Component of a 'StructuredDataElement' +data SdParameter = + SdParameter String String + deriving (Eq, Ord, Generic) + +instance Show SdParameter where + show (SdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\"" + +sdName :: String -> String +sdName = take 32 . filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"') + +sdParamValue :: String -> String +sdParamValue e = e >>= \case + '"' -> "\\\"" + '\\' -> "\\\\" + ']' -> "\\]" + x -> [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 " + +-- | An rfc 5424 facility +newtype Facility = Facility {fromFacility :: Int} + deriving (Eq, Ord, Show, Generic, NFData) + + +makeLenses ''StructuredDataElement +makeLenses ''LogMessage + +-- | Put the source location of the given callstack in 'lmSrcLoc' +setCallStack :: CallStack -> LogMessage -> LogMessage +setCallStack cs m = case getCallStack cs of + [] -> m + (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc + +instance Default LogMessage where + def = setCallStack callStack (LogMessage def def def def def def def def def def "") + +instance IsString LogMessage where + fromString = infoMessage + +-- | Render a 'LogMessage' but set the timestamp and thread id fields. +printLogMessage :: LogMessage -> IO () +printLogMessage = + setLogMessageTimestamp + >=> setLogMessageThreadId + >=> putStrLn + . renderLogMessage + +-- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps') +-- in 'lmTimestamp'. +setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage +setLogMessageTimestamp m = do + now <- liftIO getCurrentTime + return (m & lmTimestamp ?~ now) + +-- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId') +-- to 'lmMessage'. +setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage +setLogMessageThreadId m = do + t <- liftIO myThreadId + return (m & lmThreadId ?~ t) + +-- | Handle a 'Logs' effect for 'String' messages by re-logging the messages +-- as 'LogMessage's with 'debugSeverity'. +relogAsDebugMessages + :: Member (Logs LogMessage) e => Eff (Logs String ': e) a -> Eff e a +relogAsDebugMessages = withFrozenCallStack . handleLogsWith logDebug + +-- | Log a 'String' as 'LogMessage' with a given 'Severity'. +logWithSeverity :: Member (Logs LogMessage) e => Severity -> String -> Eff e () +logWithSeverity s = + withFrozenCallStack + . logMsg + . setCallStack callStack + . set lmSeverity s + . flip (set lmMessage) def + +-- | Log a 'String' as 'emergencySeverity'. +logEmergency :: Member (Logs LogMessage) e => String -> Eff e () +logEmergency = withFrozenCallStack . logWithSeverity emergencySeverity + +-- | Log a message with 'alertSeverity'. +logAlert :: Member (Logs LogMessage) e => String -> Eff e () +logAlert = withFrozenCallStack . logWithSeverity alertSeverity + +-- | Log a 'criticalSeverity' message. +logCritical :: Member (Logs LogMessage) e => String -> Eff e () +logCritical = withFrozenCallStack . logWithSeverity criticalSeverity + +-- | Log a 'errorSeverity' message. +logError :: Member (Logs LogMessage) e => String -> Eff e () +logError = withFrozenCallStack . logWithSeverity errorSeverity + +-- | Log a 'warningSeverity' message. +logWarning :: Member (Logs LogMessage) e => String -> Eff e () +logWarning = withFrozenCallStack . logWithSeverity warningSeverity + +-- | Log a 'noticeSeverity' message. +logNotice :: Member (Logs LogMessage) e => String -> Eff e () +logNotice = withFrozenCallStack . logWithSeverity noticeSeverity + +-- | Log a 'informationalSeverity' message. +logInfo :: Member (Logs LogMessage) e => String -> Eff e () +logInfo = withFrozenCallStack . logWithSeverity informationalSeverity + +-- | Log a 'debugSeverity' message. +logDebug :: Member (Logs LogMessage) e => String -> Eff e () +logDebug = withFrozenCallStack . logWithSeverity debugSeverity + +-- | Construct a 'LogMessage' with 'errorSeverity' +errorMessage :: String -> LogMessage +errorMessage m = withFrozenCallStack + (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack) + +-- | Construct a 'LogMessage' with 'informationalSeverity' +infoMessage :: String -> LogMessage +infoMessage m = withFrozenCallStack + ( def + & lmSeverity + .~ informationalSeverity + & lmMessage + .~ m + & setCallStack callStack + ) + +-- | Construct a 'LogMessage' with 'debugSeverity' +debugMessage :: String -> LogMessage +debugMessage m = withFrozenCallStack + (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack) + +-- | Construct a 'LogMessage' with 'errorSeverity' +errorMessageIO :: MonadIO m => String -> m LogMessage +errorMessageIO = + (setLogMessageThreadId >=> setLogMessageTimestamp) . errorMessage +-- | Construct a 'LogMessage' with 'informationalSeverity' +infoMessageIO :: MonadIO m => String -> m LogMessage +infoMessageIO = + (setLogMessageThreadId >=> setLogMessageTimestamp) . infoMessage +-- | Construct a 'LogMessage' with 'debugSeverity' +debugMessageIO :: MonadIO m => String -> m LogMessage +debugMessageIO = + (setLogMessageThreadId >=> setLogMessageTimestamp) . debugMessage + + +emergencySeverity :: Severity +emergencySeverity = Severity 0 + +alertSeverity :: Severity +alertSeverity = Severity 1 + +criticalSeverity :: Severity +criticalSeverity = Severity 2 + +errorSeverity :: Severity +errorSeverity = Severity 3 + +warningSeverity :: Severity +warningSeverity = Severity 4 + +noticeSeverity :: Severity +noticeSeverity = Severity 5 + +informationalSeverity :: Severity +informationalSeverity = Severity 6 + +debugSeverity :: Severity +debugSeverity = Severity 7 + +instance Default Severity where + def = debugSeverity + +kernelMessages :: Facility +kernelMessages = Facility 0 + +userLevelMessages :: Facility +userLevelMessages = Facility 1 + +mailSystem :: Facility +mailSystem = Facility 2 + +systemDaemons :: Facility +systemDaemons = Facility 3 + +securityAuthorizationMessages4 :: Facility +securityAuthorizationMessages4 = Facility 4 + +linePrinterSubsystem :: Facility +linePrinterSubsystem = Facility 6 + +networkNewsSubsystem :: Facility +networkNewsSubsystem = Facility 7 + +uucpSubsystem :: Facility +uucpSubsystem = Facility 8 + +clockDaemon :: Facility +clockDaemon = Facility 9 + +securityAuthorizationMessages10 :: Facility +securityAuthorizationMessages10 = Facility 10 + +ftpDaemon :: Facility +ftpDaemon = Facility 11 + +ntpSubsystem :: Facility +ntpSubsystem = Facility 12 + +logAuditFacility :: Facility +logAuditFacility = Facility 13 + +logAlertFacility :: Facility +logAlertFacility = Facility 14 + +clockDaemon2 :: Facility +clockDaemon2 = Facility 15 + +local0 :: Facility +local0 = Facility 16 + +local1 :: Facility +local1 = Facility 17 + +local2 :: Facility +local2 = Facility 18 + +local3 :: Facility +local3 = Facility 19 + +local4 :: Facility +local4 = Facility 20 + +local5 :: Facility +local5 = Facility 21 + +local6 :: Facility +local6 = Facility 22 + +local7 :: Facility +local7 = Facility 23 + +instance Default Facility where + def = local7 diff --git a/src/Control/Eff/Log/MessageFactory.hs b/src/Control/Eff/Log/MessageFactory.hs deleted file mode 100644 --- a/src/Control/Eff/Log/MessageFactory.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Control.Eff.Log.MessageFactory - ( mkLogMsg - , MessageFactory() - , MessageFactoryReader - , withLogMessageFactory - , composeMessageFactories - , localMessageFactory - ) -where - -import Control.Eff -import Control.Eff.Log hiding ( Severity ) -import Control.Eff.Reader.Strict -import Control.Eff.Lift -import Control.Monad.IO.Class -import Data.Default - -newtype MessageFactory m = - MessageFactory { runMessageFactory :: IO m} - -type MessageFactoryReader m = Reader (MessageFactory m) - -mkLogMsg - :: forall m io e - . ( Member (Logs m) e - , MonadIO io - , SetMember Lift (Lift io) e - , Member (MessageFactoryReader m) e - ) - => (m -> m) - -> Eff e () -mkLogMsg f = ask >>= lift . liftIO . runMessageFactory >>= logMsg . f - -localMessageFactory - :: forall m e a - . (Member (MessageFactoryReader m) e) - => IO m - -> Eff e a - -> Eff e a -localMessageFactory = local . const . MessageFactory - -composeMessageFactories - :: forall m e a - . (Member (MessageFactoryReader m) e) - => (m -> IO m) - -> Eff e a - -> Eff e a -composeMessageFactories f2 = - local (\(MessageFactory f1) -> MessageFactory (f1 >>= f2)) - -withLogMessageFactory - :: forall m io e a - . (Member (Logs m) e, Default m, MonadIO io, SetMember Lift (Lift io) e) - => Eff (MessageFactoryReader m ': e) a - -> Eff e a -withLogMessageFactory = runReader (MessageFactory (return def)) diff --git a/src/Control/Eff/Log/Syslog.hs b/src/Control/Eff/Log/Syslog.hs deleted file mode 100644 --- a/src/Control/Eff/Log/Syslog.hs +++ /dev/null @@ -1,249 +0,0 @@ --- | An RFC 5434 inspired log message and convenience functions for --- logging them. TODO document -module Control.Eff.Log.Syslog - ( Severity(fromSeverity) - , emergencySeverity - , alertSeverity - , criticalSeverity - , errorSeverity - , warningSeverity - , noticeSeverity - , informationalSeverity - , debugSeverity - , Facility(fromFacility) - , kernelMessages - , userLevelMessages - , mailSystem - , systemDaemons - , securityAuthorizationMessages4 - , linePrinterSubsystem - , networkNewsSubsystem - , uucpSubsystem - , clockDaemon - , securityAuthorizationMessages10 - , ftpDaemon - , ntpSubsystem - , logAuditFacility - , logAlertFacility - , clockDaemon2 - , local0 - , local1 - , local2 - , local3 - , local4 - , local5 - , local6 - , local7 - , LogMessage(..) - , lmFacility - , lmSeverity - , lmTimestamp - , lmHostname - , lmAppname - , lmProcessId - , lmMessageId - , lmStructuredData - , lmSrcLoc - , lmMessage - , StructuredDataElement(..) - , sdElementId - , sdElementParameters - , addSyslogTimestamps - , syslogMsg - , withSyslog - ) -where - -import Data.Time.Clock -import Data.Time.Format -import Control.Lens -import Control.Eff -import Control.Eff.Lift -import Control.Eff.Log hiding ( Severity ) -import GHC.Stack -import Data.Default -import Control.Eff.Log.MessageFactory -import Control.DeepSeq -import Control.Monad.IO.Class -import Data.Maybe -import GHC.Generics - -data LogMessage = - LogMessage { _lmFacility :: Facility - , _lmSeverity :: Severity - , _lmTimestamp :: Maybe UTCTime - , _lmHostname :: Maybe String - , _lmAppname :: Maybe String - , _lmProcessId :: Maybe String - , _lmMessageId :: Maybe String - , _lmStructuredData :: [StructuredDataElement] - , _lmSrcLoc :: Maybe SrcLoc - , _lmMessage :: String} - deriving (Eq, Generic) - -instance Show LogMessage where - show (LogMessage f s ts hn an pid mi sd loc msg) = - 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) - : (if null msg then [] else msg : maybe [] (pure . prettySrcLoc) loc)) - -instance NFData LogMessage - -data StructuredDataElement = - StructuredDataElement {_sdElementId :: String - ,_sdElementParameters :: [(String, Maybe String)]} - deriving (Eq, Ord, Show, Generic) - -instance NFData StructuredDataElement - -instance Default LogMessage where - def = LogMessage local7 debugSeverity def def def def def def def "" - --- | An rfc 5424 severity -newtype Severity = Severity {fromSeverity :: Int} - deriving (Eq, Ord, Show, Generic, NFData) - -emergencySeverity :: Severity -emergencySeverity = Severity 0 - -alertSeverity :: Severity -alertSeverity = Severity 1 - -criticalSeverity :: Severity -criticalSeverity = Severity 2 - -errorSeverity :: Severity -errorSeverity = Severity 3 - -warningSeverity :: Severity -warningSeverity = Severity 4 - -noticeSeverity :: Severity -noticeSeverity = Severity 5 - -informationalSeverity :: Severity -informationalSeverity = Severity 6 - -debugSeverity :: Severity -debugSeverity = Severity 7 - --- | An rfc 5424 facility -newtype Facility = Facility {fromFacility :: Int} - deriving (Eq, Ord, Show, Generic, NFData) - -kernelMessages :: Facility -kernelMessages = Facility 0 - -userLevelMessages :: Facility -userLevelMessages = Facility 1 - -mailSystem :: Facility -mailSystem = Facility 2 - -systemDaemons :: Facility -systemDaemons = Facility 3 - -securityAuthorizationMessages4 :: Facility -securityAuthorizationMessages4 = Facility 4 - -linePrinterSubsystem :: Facility -linePrinterSubsystem = Facility 6 - -networkNewsSubsystem :: Facility -networkNewsSubsystem = Facility 7 - -uucpSubsystem :: Facility -uucpSubsystem = Facility 8 - -clockDaemon :: Facility -clockDaemon = Facility 9 - -securityAuthorizationMessages10 :: Facility -securityAuthorizationMessages10 = Facility 10 - -ftpDaemon :: Facility -ftpDaemon = Facility 11 - -ntpSubsystem :: Facility -ntpSubsystem = Facility 12 - -logAuditFacility :: Facility -logAuditFacility = Facility 13 - -logAlertFacility :: Facility -logAlertFacility = Facility 14 - -clockDaemon2 :: Facility -clockDaemon2 = Facility 15 - -local0 :: Facility -local0 = Facility 16 - -local1 :: Facility -local1 = Facility 17 - -local2 :: Facility -local2 = Facility 18 - -local3 :: Facility -local3 = Facility 19 - -local4 :: Facility -local4 = Facility 20 - -local5 :: Facility -local5 = Facility 21 - -local6 :: Facility -local6 = Facility 22 - -local7 :: Facility -local7 = Facility 23 - -makeLenses ''StructuredDataElement -makeLenses ''LogMessage - -addSyslogTimestamps - :: ( MonadIO io - , SetMember Lift (Lift io) e - , Member (Logs LogMessage) e - , Member (MessageFactoryReader LogMessage) e - ) - => Eff e a - -> Eff e a -addSyslogTimestamps = composeMessageFactories $ \m -> do - now <- getCurrentTime - return (m & lmTimestamp ?~ now) - -syslogMsg - :: ( HasCallStack - , MonadIO io - , SetMember Lift (Lift io) e - , Member (Logs LogMessage) e - , Member (MessageFactoryReader LogMessage) e - ) - => (LogMessage -> LogMessage) - -> Eff e () -syslogMsg f = mkLogMsg (f . setCallStack callStack) - where - setCallStack :: CallStack -> LogMessage -> LogMessage - setCallStack cs m = case getCallStack cs of - [] -> m - (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc - -withSyslog - :: forall io e a - . ( Member (Logs LogMessage) e - , Default LogMessage - , MonadIO io - , SetMember Lift (Lift io) e - ) - => Eff (MessageFactoryReader LogMessage ': e) a - -> Eff e a -withSyslog = withLogMessageFactory . addSyslogTimestamps diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,5 +1,4 @@ -module Common -where +module Common where import Control.Concurrent.STM import Control.Eff.Concurrent.Process @@ -20,7 +19,7 @@ timeoutSeconds seconds = Timeout (seconds * 1000000) (show seconds ++ "s") withTestLogC - :: (e -> LogChannel String -> IO ()) + :: (e -> LogChannel LogMessage -> IO ()) -> (IO (e -> IO ()) -> TestTree) -> TestTree withTestLogC doSchedule k = withResource @@ -35,16 +34,16 @@ ) ) -testLogC :: IO (LogChannel String) +testLogC :: IO (LogChannel LogMessage) testLogC = - filterLogChannel (\m -> take (length logPrefix) m == logPrefix) - <$> forkLogger 1 (putStrLn) Nothing + filterLogChannel (\m -> take (length logPrefix) (_lmMessage m) == logPrefix) + <$> forkLogger 1 printLogMessage Nothing -testLogJoin :: LogChannel String -> IO () -testLogJoin = joinLogChannel Nothing +testLogJoin :: LogChannel LogMessage -> IO () +testLogJoin = joinLogChannel -tlog :: Member (Logs String) r => String -> Eff r () -tlog = logMsg . (logPrefix ++) +tlog :: Member (Logs LogMessage) r => String -> Eff r () +tlog = logInfo . (logPrefix ++) logPrefix :: String logPrefix = "[TEST] " @@ -58,7 +57,7 @@ scheduleAndAssert :: forall r - . (SetMember Lift (Lift IO) r, Member (Logs String) r) + . (SetMember Lift (Lift IO) r, Member (Logs LogMessage) r) => IO (Eff (Process r ': r) () -> IO ()) -> ( (String -> Bool -> Eff (Process r ': r) ()) -> Eff (Process r ': r) () @@ -78,7 +77,7 @@ applySchedulerFactory :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> Eff (Process r ': r) () -> IO () diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs --- a/test/LoggingTests.hs +++ b/test/LoggingTests.hs @@ -33,3 +33,6 @@ toOtherLogMsg :: ('[Logs String, Logs OtherLogMsg] <:: e) => String -> Eff e () toOtherLogMsg = logMsg . OtherLogMsg + +demo2 :: Member (Logs LogMessage) e => Eff e () +demo2 = relogAsDebugMessages demo diff --git a/test/ProcessBehaviourTestCases.hs b/test/ProcessBehaviourTestCases.hs --- a/test/ProcessBehaviourTestCases.hs +++ b/test/ProcessBehaviourTestCases.hs @@ -1,5 +1,4 @@ -module ProcessBehaviourTestCases -where +module ProcessBehaviourTestCases where import Data.List ( sort ) import Data.Dynamic @@ -33,7 +32,7 @@ (withTestLogC (\e logC -> -- void (runLift (logToChannel logC (SingleThreaded.schedule (return ()) e))) - let runEff :: Eff '[Logs String, Lift IO] a -> IO a + let runEff :: Eff '[Logs LogMessage, Lift IO] a -> IO a runEff = runLift . logToChannel logC in void $ SingleThreaded.scheduleM runEff yield e ) @@ -43,7 +42,7 @@ allTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree allTests schedulerFactory = localOption @@ -61,7 +60,7 @@ yieldLoopTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree yieldLoopTests schedulerFactory @@ -100,7 +99,7 @@ pingPongTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree pingPongTests schedulerFactory = testGroup @@ -175,7 +174,7 @@ errorTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree errorTests schedulerFactory @@ -249,7 +248,7 @@ concurrencyTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree concurrencyTests schedulerFactory @@ -292,10 +291,11 @@ m <- receiveMessage px void (sendMessage px me m) ) - child2 <- spawn (foreverCheap (void (sendMessage px 888 (toDyn "")))) - True <- sendMessageChecked px child1 (toDyn "test") - i <- receiveMessageAs px - True <- sendShutdownChecked px child2 + child2 <- spawn + (foreverCheap (void (sendMessage px 888 (toDyn "")))) + True <- sendMessageChecked px child1 (toDyn "test") + i <- receiveMessageAs px + True <- sendShutdownChecked px child2 assertEff "" (i == "test") , testCase "most processes send foreverCheap" $ scheduleAndAssert schedulerFactory @@ -395,7 +395,7 @@ exitTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree exitTests schedulerFactory = @@ -495,8 +495,8 @@ , (howToExit, doExit ) <- [ ("normally" , void (exitNormally px)) , ("simply returning", return ()) - , ("raiseError" , void (raiseError px "test error raised")) - , ("exitWithError" , void (exitWithError px "test error exit")) + , ("raiseError", void (raiseError px "test error raised")) + , ("exitWithError", void (exitWithError px "test error exit")) , ( "sendShutdown to self" , do me <- self px @@ -509,7 +509,7 @@ sendShutdownTests :: forall r - . (Member (Logs String) r, SetMember Lift (Lift IO) r) + . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) => IO (Eff (Process r ': r) () -> IO ()) -> TestTree sendShutdownTests schedulerFactory =