diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ sources: - hvr-ghc packages: - - ghc-8.2.2 + - ghc-8.6.3 before_install: - mkdir -p ~/.local/bin diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -0,0 +1,2 @@ +{ pkgs ? (import {}) }: +pkgs.callPackage ./extensible-effects-concurrent.nix {} 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 @@ -3,7 +3,6 @@ import GHC.Stack import Control.Eff -import Control.Eff.Lift import Control.Monad import Data.Dynamic import Control.Eff.Concurrent @@ -32,7 +31,7 @@ mainProcessSpawnsAChildAndReturns :: HasCallStack => Eff (InterruptableProcess q) () mainProcessSpawnsAChildAndReturns = void (spawn (void receiveAnyMessage)) -example:: ( HasCallStack, HasLogging IO q) => Eff (InterruptableProcess q) () +example:: ( HasCallStack, Member Logs q, Lifted IO q) => Eff (InterruptableProcess q) () example = do me <- self logInfo ("I am " ++ show me) @@ -64,7 +63,8 @@ testServerLoop :: forall q . ( HasCallStack - , HasLogging IO q + , Member Logs q + , Lifted IO q ) => Eff (InterruptableProcess q) (Server TestApi) testServerLoop = spawnApiServer 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 @@ -3,7 +3,6 @@ import Data.Dynamic import Control.Eff -import Control.Eff.Lift import Control.Eff.Concurrent import Control.Eff.State.Strict import Control.Monad @@ -23,7 +22,7 @@ deriving Typeable counterExample - :: (Member (Logs LogMessage) q, Lifted IO q) + :: (Member Logs q, Lifted IO q) => Eff (InterruptableProcess q) () counterExample = do (c, (co, (_sdp, cp))) <- spawnCounter @@ -62,7 +61,7 @@ deriving (Show, Typeable) spawnCounter - :: (Member (Logs LogMessage) q) + :: (Member Logs q) => Eff (InterruptableProcess q) ( Server Counter @@ -127,7 +126,7 @@ deriving instance Show (Api Counter x) logCounterObservations - :: (Member (Logs LogMessage) q) + :: (Member Logs q) => Eff (InterruptableProcess q) (Observer CounterChanged) logCounterObservations = do svr <- spawnApiServer 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 @@ -1,44 +1,26 @@ module Main where -import Control.Concurrent -import Control.Eff.Lift +import Control.Eff import Control.Eff.Log -import Control.Exception as IOException -import System.Directory -import System.FilePath -import System.IO +import Control.Lens main :: IO () -main = withAsyncLogChannel - (1000 :: Int) - (ioLogMessageWriter - (fileAppender "extensible-effects-concurrent-example-3.log") - ) - (handleLoggingAndIO - (do - logInfo "test 1" - lift (threadDelay 1000000) - logDebug "test 2" - lift (threadDelay 1000000) - logCritical "test 3" - lift (threadDelay 1000000) - ) - ) +main = + runLift + $ withSomeLogging @IO + $ withLogFileAppender "extensible-effects-concurrent-example-3.log" + $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced: "++)) debugTraceLogWriter)) + $ modifyLogWriter (defaultIoLogWriter "example-3" local0) + $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced without timestamp: "++)) 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" -fileAppender :: FilePath -> LogWriter String IO -fileAppender fnIn = multiMessageLogWriter - (\writeLogMessageWith -> bracket - (do - fnCanon <- canonicalizePath fnIn - createDirectoryIfMissing True (takeDirectory fnCanon) - h <- openFile fnCanon AppendMode - hSetBuffering h (BlockBuffering (Just 1024)) - return h - ) - (\h -> IOException.try @SomeException (hFlush h) >> hClose h) - (writeLogMessageWith . hPutStrLn) - ) -fileAppenderSimple :: FilePath -> LogWriter String IO -fileAppenderSimple fnIn = - singleMessageLogWriter (\msg -> withFile fnIn AppendMode (`hPutStrLn` msg)) +testPred :: LogPredicate +testPred = view (lmSeverity . to (<= errorSeverity)) 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 @@ -1,23 +1,25 @@ module Main where import Control.Eff -import Control.Eff.Lift import Control.Eff.Concurrent import Data.Dynamic import Control.Concurrent import Control.DeepSeq +import GHC.Stack (HasCallStack) main :: IO () -main = defaultMain - (do - lift (threadDelay 100000) -- because of async logging - firstExample - lift (threadDelay 100000) -- ... async logging - ) +main = + defaultMainWithLogWriter + (defaultIoLogWriter "example-4" local0 consoleLogWriter) + $ do + lift (threadDelay 100000) -- because of async logging + firstExample + lift (threadDelay 100000) -- ... async logging + newtype WhoAreYou = WhoAreYou ProcessId deriving (Typeable, NFData, Show) -firstExample :: (HasLogging IO q) => Eff (InterruptableProcess q) () +firstExample :: (HasCallStack, Member Logs q) => Eff (InterruptableProcess q) () firstExample = do person <- spawn (do diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: extensible-effects-concurrent -version: 0.18.1 +version: 0.19.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 @@ -7,12 +8,11 @@ author: Sven Heyll maintainer: sven.heyll@gmail.com category: Concurrency, Control, Effect -tested-with: GHC==8.2.2, GHC==8.4.3, GHC==8.4.4, GHC==8.6.1 +tested-with: GHC==8.6.4 copyright: Copyright Sven Heyll license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: 2.0 extra-doc-files: docs/extensible-effects-concurrent-test-Loop-without-space-leaks.png @@ -20,7 +20,11 @@ extra-source-files: stack.yaml - stack.nightly-2018-05-29.yaml + extensible-effects-concurrent.nix + default.nix + shell.nix + release.nix + with-hoogle.nix ChangeLog.md README.md brittany.yaml @@ -35,21 +39,23 @@ src build-depends: async >= 2.2 && <3, - base >=4.7 && <5, + base >= 4.12 && <5, data-default >= 0.7 && < 0.8, deepseq >= 1.4 && < 1.5, + directory, + hostname, exceptions >= 0.10 && < 0.11, safe-exceptions >= 0.1 && < 0.2, filepath >= 1.4 && < 1.5, time >= 1.8 && < 1.9, mtl >= 2.2 && < 2.3, containers >=0.5.8 && <0.7, - QuickCheck <2.12, + QuickCheck, lens >= 4.14 && < 4.18, parallel >= 3.2 && < 3.3, process >= 1.6 && < 1.7, monad-control >= 1.0 && < 1.1, - extensible-effects >= 3.1.0.2 && <4, + extensible-effects >= 5 && < 6, stm >= 2.4.5 && <2.6, transformers-base >= 0.4 && < 0.5 autogen-modules: Paths_extensible_effects_concurrent @@ -60,6 +66,7 @@ Control.Eff.Log.Channel, Control.Eff.Log.Handler, Control.Eff.Log.Message, + Control.Eff.Log.Writer, Control.Eff.Concurrent, Control.Eff.Concurrent.Api, Control.Eff.Concurrent.Api.Client, @@ -113,7 +120,7 @@ , extensible-effects-concurrent , extensible-effects , lens - ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -fno-full-laziness default-language: Haskell2010 default-extensions: AllowAmbiguousTypes , BangPatterns @@ -141,7 +148,7 @@ , extensible-effects-concurrent , extensible-effects , lens - ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -fno-full-laziness default-language: Haskell2010 default-extensions: AllowAmbiguousTypes , BangPatterns @@ -171,7 +178,7 @@ , extensible-effects , filepath , lens - ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -fno-full-laziness default-language: Haskell2010 default-extensions: AllowAmbiguousTypes , BangPatterns @@ -198,7 +205,7 @@ , extensible-effects-concurrent , extensible-effects , deepseq - ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -fno-full-laziness default-language: Haskell2010 default-extensions: AllowAmbiguousTypes , BangPatterns @@ -230,19 +237,19 @@ , LoopTests , ProcessBehaviourTestCases , SingleThreadedScheduler - ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -fno-full-laziness build-depends: async - , base >=4.7 && <5 + , base , data-default , extensible-effects-concurrent - , extensible-effects >= 3.1.0.2 && < 3.2 + , extensible-effects , tasty , tasty-discover , tasty-hunit , containers , deepseq - , QuickCheck <2.12 + , QuickCheck , lens , HUnit , stm diff --git a/extensible-effects-concurrent.nix b/extensible-effects-concurrent.nix new file mode 100644 --- /dev/null +++ b/extensible-effects-concurrent.nix @@ -0,0 +1,13 @@ +{ lib, haskellPackages }: +let + cleanSrc = lib.cleanSourceWith { + filter = (path: type: + let base = baseNameOf (toString path); + in !(lib.hasPrefix ".ghc.environment." base) && + !(lib.hasSuffix ".nix" base) + ); + src = lib.cleanSource ./.; + }; + + in haskellPackages.callCabal2nix + "extensible-effects-concurrent" cleanSrc {} diff --git a/release.nix b/release.nix new file mode 100644 --- /dev/null +++ b/release.nix @@ -0,0 +1,2 @@ +{ pkgs ? (import {}) }: +pkgs.callPackage ./extensible-effects-concurrent.nix {} diff --git a/shell.nix b/shell.nix new file mode 100644 --- /dev/null +++ b/shell.nix @@ -0,0 +1,2 @@ +{ pkgs ? (import {}) }: +pkgs.callPackage ./extensible-effects-concurrent.nix {} 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 @@ -214,18 +214,16 @@ import Control.Eff.Concurrent.Process.ForkIOScheduler ( schedule , defaultMain - , defaultMainWithLogChannel + , defaultMainWithLogWriter , ProcEff , InterruptableProcEff , SchedulerIO , HasSchedulerIO - , forkIoScheduler ) import Control.Eff.Concurrent.Process.SingleThreadedScheduler ( schedulePure , defaultMainSingleThreaded - , singleThreadedIoScheduler ) import Control.Eff.Log import Control.Eff.Loop 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 @@ -79,7 +79,7 @@ registerObserver observer observerRegistry = cast observerRegistry (RegisterObserver observer) --- | Send the 'forgetObserverMessage' +-- | Send the 'ForgetObserver' message -- -- @since 0.16.0 forgetObserver @@ -109,7 +109,7 @@ -- | Based on the 'Api' instance for 'Observer' this simplified writing -- a callback handler for observations. In order to register to --- and 'ObservationRegistry' use 'toObserver'. +-- and 'ObserverRegistry' use 'toObserver'. -- -- @since 0.16.0 handleObservations @@ -121,7 +121,7 @@ Observed o -> k o ) --- | Use a 'Server' as an 'Observer' for 'handleObserved'. +-- | Use a 'Server' as an 'Observer' for 'handleObservations'. -- -- @since 0.16.0 toObserver :: Typeable o => Server (Observer o) -> Observer o @@ -148,7 +148,7 @@ data ObserverRegistry o -- | Api for managing observers. This can be added to any server for any number of different observation types. --- The functions 'manageObservers' and 'handleObserverApi' are used to include observer handling; +-- The functions 'manageObservers' and 'handleObserverRegistration' are used to include observer handling; -- -- @since 0.16.0 data instance Api (ObserverRegistry o) r where @@ -165,7 +165,7 @@ -- ** Api for integrating 'ObserverRegistry' into processes. --- | Provide the implementation for the 'Observerd' Api, this handled 'RegisterObserver' and 'ForgetObserver' +-- | Provide the implementation for the 'ObserverRegistry' Api, this handled 'RegisterObserver' and 'ForgetObserver' -- messages. It also adds the 'ObserverState' constraint to the effect list. -- -- @since 0.16.0 @@ -192,8 +192,9 @@ ) --- | Keep track of registered 'Observer's Observers can be added and removed, --- and an 'Observation' can be sent to all registerd observers at once. +-- | Keep track of registered 'Observer's. +-- +-- Handle the 'ObserverState' introduced by 'handleObserverRegistration'. -- -- @since 0.16.0 manageObservers :: Eff (ObserverState o ': r) a -> Eff r a 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 @@ -13,7 +13,6 @@ import Control.Concurrent.STM import Control.Eff import Control.Eff.ExceptionExtra ( ) -import Control.Eff.Lift import Control.Eff.Concurrent.Process import Control.Eff.Log import Control.Eff.Concurrent.Api.Observer @@ -25,8 +24,8 @@ import Data.Typeable import GHC.Stack --- | Contains a 'TBQueue' capturing observations received by 'enqueueObservationsRegistered' --- or 'spawnLinkObservationQueueWriter'. +-- | Contains a 'TBQueue' capturing observations. +-- See 'spawnLinkObservationQueueWriter', 'readObservationQueue'. newtype ObservationQueue a = ObservationQueue (TBQueue a) -- | A 'Reader' for an 'ObservationQueue'. @@ -44,7 +43,7 @@ , HasCallStack , MonadIO (Eff r) , Typeable o - , HasLogging IO r + , Member Logs r ) => Eff r o readObservationQueue = do @@ -60,23 +59,24 @@ , HasCallStack , MonadIO (Eff r) , Typeable o - , HasLogging IO r + , Member Logs r ) => Eff r (Maybe o) tryReadObservationQueue = do ObservationQueue q <- ask @(ObservationQueue o) liftIO (atomically (tryReadTBQueue q)) --- | Read at once all currently queued observations captured and enqueued in the shared 'TBQueue' by 'spawnLinkObservationQueueWriter'. --- This returns immediately all currently enqueued 'Observation's. For a blocking --- variant use 'readObservationQueue'. +-- | Read at once all currently queued observations captured and enqueued +-- in the shared 'TBQueue' by 'spawnLinkObservationQueueWriter'. +-- This returns immediately all currently enqueued observations. +-- For a blocking variant use 'readObservationQueue'. flushObservationQueue :: forall o r . ( Member (ObservationQueueReader o) r , HasCallStack , MonadIO (Eff r) , Typeable o - , HasLogging IO r + , Member Logs r ) => Eff r [o] flushObservationQueue = do @@ -105,7 +105,8 @@ . ( HasCallStack , Typeable o , Show o - , HasLogging IO e + , Member Logs e + , Lifted IO e , Integral len , Member Interrupts e ) @@ -113,14 +114,14 @@ -> Eff (ObservationQueueReader o ': e) b -> Eff e b withObservationQueue queueLimit e = do - q <- liftIO (newTBQueueIO (fromIntegral queueLimit)) + q <- lift (newTBQueueIO (fromIntegral queueLimit)) res <- handleInterrupts (return . Left) (Right <$> runReader (ObservationQueue q) e) - rest <- liftIO (atomically (flushTBQueue q)) + rest <- lift (atomically (flushTBQueue q)) unless (null rest) (logNotice (logPrefix (Proxy @o) ++ " unread observations: " ++ show rest)) - either (\em -> logError (show em) >> liftIO (throwIO em)) return res + either (\em -> logError (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. @@ -132,7 +133,7 @@ -- @since 0.18.0 spawnLinkObservationQueueWriter :: forall o q - . (Typeable o, Show o, HasLogging IO q, Lifted IO q, HasCallStack) + . (Typeable o, Show o, Member Logs q, Lifted IO q, HasCallStack) => ObservationQueue o -> Eff (InterruptableProcess q) (Observer o) spawnLinkObservationQueueWriter (ObservationQueue q) = do 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 @@ -12,7 +12,7 @@ -- ** Api Server Callbacks , CallbackResult(..) , MessageCallback(..) - -- ** Callback Smart Contructors + -- ** Callback Smart Constructors -- *** Calls and Casts (for 'Api's) , handleCasts , handleCalls @@ -124,9 +124,9 @@ -> MessageCallback api serverEff -> InterruptCallback serverEff -> Eff (InterruptableProcess eff) (ServerPids api) -spawnApiServerEffectful handleServerInteralEffects scb icb = +spawnApiServerEffectful handleServerInternalEffects scb icb = toServerPids (Proxy @api) - <$> spawn (handleServerInteralEffects (apiServerLoop scb icb)) + <$> spawn (handleServerInternalEffects (apiServerLoop scb icb)) -- | /Server/ an 'Api' in a newly spawned process; The caller provides an @@ -145,11 +145,11 @@ -> MessageCallback api serverEff -> InterruptCallback serverEff -> Eff (InterruptableProcess eff) (ServerPids api) -spawnLinkApiServerEffectful handleServerInteralEffects scb icb = +spawnLinkApiServerEffectful handleServerInternalEffects scb icb = toServerPids (Proxy @api) - <$> spawnLink (handleServerInteralEffects (apiServerLoop scb icb)) + <$> spawnLink (handleServerInternalEffects (apiServerLoop scb icb)) --- | Receive loop for 'Api' 'call's. This starts a receive loop for +-- | Receive loop for 'Api' 'Control.Eff.Concurrent.Api.Client.call's. This starts a receive loop for -- a 'MessageCallback'. It is used behind the scenes by 'spawnLinkApiServerEffectful' -- and 'spawnApiServerEffectful'. -- @@ -182,17 +182,16 @@ handleCallbackResult (Right (Left r)) = intCb r >>= handleCallbackResult . Left --- | A command to the server loop started e.g. by 'server' or 'spawnServerWithEffects'. --- Typically returned by an 'ApiHandler' member to indicate if the server +-- | A command to the server loop started by 'apiServerLoop'. +-- Typically returned by a 'MessageCallback' to indicate if the server -- should continue or stop. -- -- @since 0.13.2 data CallbackResult where -- | Tell the server to keep the server loop running AwaitNext :: CallbackResult - -- | Tell the server to exit, this will make 'serve' stop handling requests without - -- exitting the process. '_terminateCallback' will be invoked with the given - -- optional reason. + -- | Tell the server to exit, this will cause 'apiServerLoop' to stop handling requests without + -- exiting the process. StopServer :: InterruptReason -> CallbackResult -- SendReply :: reply -> CallbackResult () -> CallbackResult (reply -> Eff eff ()) deriving ( Typeable ) @@ -378,7 +377,7 @@ -> MessageCallback '[] eff handleProcessDowns k = MessageCallback selectMessage (k . downReference) --- | Compose two 'Api's to a type-leve pair of them. +-- | Compose two 'Api's to a type-level pair of them. -- -- > handleCalls api1calls ^: handleCalls api2calls ^: -- @@ -424,11 +423,12 @@ -- @since 0.13.2 logUnhandledMessages :: forall eff - . (Member (Logs LogMessage) eff, HasCallStack) + . (Member Logs eff, HasCallStack) => MessageCallback '[] eff logUnhandledMessages = MessageCallback selectAnyMessageLazy $ \msg -> do logWarning ("ignoring unhandled message " ++ show msg) return AwaitNext + -- | Helper type class for the return values of 'spawnApiServer' et al. -- 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 @@ -120,7 +120,6 @@ import Control.Eff.Exception import Control.Eff.Extend import Control.Eff.Log.Handler -import Control.Eff.Log.Message import Control.Lens import Control.Monad ( void , (>=>) @@ -176,7 +175,7 @@ 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)) - -- | Shutdown the process; irregardles of the exit reason, this function never + -- | Shutdown the process; irregardless of the exit reason, this function never -- returns, Shutdown :: ExitReason 'NoRecovery -> Process r a -- | Raise an error, that can be handled. @@ -186,13 +185,13 @@ -- interrupt and continue as if nothing happened. 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 + -- 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 ()) - -- | Receive a message that matches a criterium. + -- | Receive a message that matches a criteria. -- This should block until an a message was received. The message is returned - -- as a 'ProcessMessage' value. The function should also return if an exception + -- 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. @@ -203,7 +202,7 @@ -- There can be multiple monitors on the same process, -- and a message for each will be sent. -- If the process is already dead, the 'ProcessDown' message - -- will be sent immediately, w.thout exit reason + -- will be sent immediately, without exit reason -- -- @since 0.12.0 Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference) @@ -213,11 +212,11 @@ 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 'ProcessExitReaon' 'LinkedProcessCrashed'. + -- is shutdown with the 'ExitReason' 'LinkedProcessCrashed'. -- -- @since 0.12.0 Link :: ProcessId -> Process r (ResumeProcess ()) - -- | Unlink the calling proccess from the other process. + -- | Unlink the calling process from the other process. -- -- @since 0.12.0 Unlink :: ProcessId -> Process r (ResumeProcess ()) @@ -276,7 +275,7 @@ instance NFData1 ResumeProcess --- | A function that deciced if the next message will be received by +-- | A function that decided if the next message will be received by -- 'ReceiveSelectedMessage'. It conveniently is an instance of -- 'Alternative' so the message selector can be combined: -- > @@ -395,7 +394,7 @@ -- @__r__@ in @'Process' r : r@, this might be dependent on the -- scheduler implementation. data SchedulerProxy :: [Type -> Type] -> Type where - -- | Tell the typechecker what effects we have below 'Process' + -- | Tell the type checker what effects we have below 'Process' SchedulerProxy :: SchedulerProxy q -- | Like 'SchedulerProxy' but shorter SP :: SchedulerProxy q @@ -412,8 +411,8 @@ -- | The state that a 'Process' is currently in. data ProcessState = ProcessBooting -- ^ The process has just been started but not - -- called 'handleProcess' yet. - | ProcessIdle -- ^ The process yielded it's timeslice + -- scheduled yet. + | ProcessIdle -- ^ The process yielded it's time slice | ProcessBusy -- ^ The process is busy with non-blocking | ProcessBusySending -- ^ The process is busy with sending a message | ProcessBusySendingShutdown -- ^ The process is busy with killing @@ -447,7 +446,7 @@ NoRecovery -> showString "not recoverable" ) --- | Get the 'ExitRecover'y +-- | Get the 'ExitRecovery' toExitRecovery :: ExitReason r -> ExitRecovery toExitRecovery = \case ProcessFinished -> Recoverable @@ -459,7 +458,7 @@ (UnexpectedException _ _) -> NoRecovery Killed -> NoRecovery --- | This value indicates wether a process exited in way consistent with +-- | This value indicates whether a process exited in way consistent with -- the planned behaviour or not. data ExitSeverity = NormalExit | Crash deriving (Typeable, Ord, Eq, Generic) @@ -483,12 +482,12 @@ _ -> Crash -- | A sum-type with reasons for why a process exists the scheduling loop, --- this includes errors, that can occur when scheduleing messages. +-- this includes errors, that can occur when scheduling messages. data ExitReason (t :: ExitRecovery) where -- | A process has finished a unit of work and might exit or work on - -- something else. This is primarily used for interupting infinite + -- something else. This is primarily used for interrupting infinite -- server loops, allowing for additional cleanup work before - -- exitting (e.g. with 'ExitNormally') + -- exiting (e.g. with 'ExitNormally') -- -- @since 0.13.2 ProcessFinished @@ -603,7 +602,7 @@ -- See 'handleInterrupts', 'exitOnInterrupt' or 'provideInterrupts' type Interrupts = Exc InterruptReason --- | This adds a layer of the 'Interrupts' effect ontop of 'ConsProcess' +-- | This adds a layer of the 'Interrupts' effect on top of 'ConsProcess' type InterruptableProcess e = Interrupts ': ConsProcess e -- | Handle all 'InterruptReason's of an 'InterruptableProcess' by @@ -639,7 +638,7 @@ -- | Handle interrupts by logging them with `logProcessExit` and otherwise -- ignoring them. logInterrupts - :: (HasCallStack, '[Interrupts, Logs LogMessage] <:: r) + :: forall r . (Member Logs r, HasCallStack, Member Interrupts r) => Eff r () -> Eff r () logInterrupts = handleInterrupts logProcessExit @@ -667,7 +666,7 @@ :: Either InterruptReason (ExitReason 'NoRecovery) -> ExitReason 'NoRecovery mergeEitherInterruptAndExitReason = either NotRecovered id --- | Throw an 'InterruptReason', can be handled by 'recoverFromInterrupt' or +-- | Throw an 'InterruptReason', can be handled by 'handleInterrupts' or -- 'exitOnInterrupt' or 'provideInterrupts'. interrupt :: (HasCallStack, Member Interrupts r) => InterruptReason -> Eff r a interrupt = throwError @@ -680,7 +679,7 @@ isCrash _ = True -- | A predicate for recoverable exit reasons. This predicate defines the --- exit reasonson which functions such as 'executeAndResume' +-- exit reasons which functions such as 'executeAndResume' isRecoverable :: ExitReason x -> Bool isRecoverable (toExitRecovery -> Recoverable) = True isRecoverable _ = False @@ -731,9 +730,8 @@ toCrashReason e | isCrash e = Just (show e) | otherwise = Nothing --- | Log the 'ProcessExitReaons' -logProcessExit - :: (HasCallStack, Member (Logs LogMessage) e) => ExitReason x -> Eff e () +-- | Log the 'ExitReason's +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)) @@ -845,7 +843,7 @@ -- | Start a new process, the new process will execute an effect, the function -- will return immediately with a 'ProcessId'. If the new process is -- interrupted, the process will 'Shutdown' with the 'InterruptReason' --- wrapped in 'NotCovered'. For specific use cases it might be better to use +-- wrapped in 'NotRecovered'. For specific use cases it might be better to use -- 'spawnRaw'. spawn :: forall r q @@ -955,7 +953,7 @@ -- Only the messages of the given type will be received. -- If the process is interrupted by an exception of by a 'SendShutdown' from -- another process, with an exit reason that satisfies 'isRecoverable', then --- the callback will be invoked with @'Left' 'ProcessExitReaon'@, otherwise the +-- the callback will be invoked with @'Left' 'ExitReason'@, otherwise the -- process will be exited with the same reason using 'exitBecause'. -- See also 'ReceiveSelectedMessage' for more documentation. receiveSelectedLoop @@ -964,12 +962,12 @@ => MessageSelector a -> (Either InterruptReason a -> Eff r (Maybe endOfLoopResult)) -> Eff r endOfLoopResult -receiveSelectedLoop selectMesage handlers = do - mReq <- send (ReceiveSelectedMessage @q @a selectMesage) +receiveSelectedLoop selector handlers = do + mReq <- send (ReceiveSelectedMessage @q @a selector) mRes <- case mReq of Interrupted reason -> handlers (Left reason) ResumeWith message -> handlers (Right message) - maybe (receiveSelectedLoop selectMesage handlers) return mRes + maybe (receiveSelectedLoop selector handlers) return mRes -- | Like 'receiveSelectedLoop' but /not selective/. -- See also 'selectAnyMessageLazy', 'receiveSelectedLoop'. @@ -1024,7 +1022,7 @@ -- There can be multiple monitors on the same process, -- and a message for each will be sent. -- If the process is already dead, the 'ProcessDown' message --- will be sent immediately, w.thout exit reason +-- will be sent immediately, without exit reason -- -- @since 0.12.0 monitor @@ -1057,7 +1055,7 @@ => ProcessId -> (MonitorReference -> Eff r a) -> Eff r a -withMonitor pid eff = monitor pid >>= \ref -> eff ref <* demonitor ref +withMonitor pid e = monitor pid >>= \ref -> e ref <* demonitor ref -- | A 'MessageSelector' for receiving either a monitor of the -- given process or another message. @@ -1082,7 +1080,7 @@ -- | A monitored process exited. -- This message is sent to a process by the scheduler, when --- a process that was monitored via a 'SchedulerCommand' died. +-- a process that was monitored died. -- -- @since 0.12.0 data ProcessDown = @@ -1092,9 +1090,10 @@ } deriving (Typeable, Generic, Eq, Ord) --- | Trigger an 'Interrupt' for a 'ProcessDown' message. --- The reason will be 'ProcessNotRunning' +-- | Make an 'InterruptReason' for a 'ProcessDown' message. -- +-- For example: @doSomething >>= either (interrupt . becauseProcessIsDown) return@ +-- -- @since 0.12.0 becauseProcessIsDown :: ProcessDown -> InterruptReason becauseProcessIsDown = ProcessNotRunning . monitoredProcess . downReference @@ -1112,7 +1111,7 @@ . showsPrec 11 reason ) --- | A 'MesssageSelector' for the 'ProcessDown' message of a specific +-- | A 'MessageSelector' for the 'ProcessDown' message of a specific -- process. -- -- @since 0.12.0 @@ -1122,7 +1121,7 @@ -- | 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 'ProcessExitReaon' 'LinkedProcessCrashed'. +-- is shutdown with the 'ExitReason' 'LinkedProcessCrashed'. -- -- @since 0.12.0 linkProcess @@ -1132,7 +1131,7 @@ -> Eff r () linkProcess = executeAndResumeOrThrow . Link . force --- | Unlink the calling proccess from the other process. +-- | Unlink the calling process from the other process. -- -- @since 0.12.0 unlinkProcess @@ -1142,7 +1141,7 @@ -> Eff r () unlinkProcess = executeAndResumeOrThrow . Unlink . force --- | Exit the process with a 'ProcessExitReaon'. +-- | Exit the process with a 'ExitReason'. exitBecause :: forall r q a . (HasCallStack, SetMember Process (Process q) r) 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 @@ -1,7 +1,7 @@ -- | Implement Erlang style message passing concurrency. -- --- This handles the 'MessagePassing' and 'Process' effects, using --- 'STM.TQueue's and 'forkIO'. +-- This module contains 'spawn' which handles the 'Process' effects, using +-- 'STM.TQueue's and 'Control.Concurrent.Async.withAsync'. -- -- This aims to be a pragmatic implementation, so even logging is -- supported. @@ -10,127 +10,112 @@ -- and creates all of the internal state stored in 'STM.TVar's -- to manage processes with message queues. -- --- The 'Eff' handler for 'Process' and 'MessagePassing' use --- are implemented and available through 'spawn'. --- module Control.Eff.Concurrent.Process.ForkIOScheduler ( schedule , defaultMain - , defaultMainWithLogChannel + , defaultMainWithLogWriter , ProcEff , InterruptableProcEff , SchedulerIO , HasSchedulerIO - , forkIoScheduler - ) -where + ) where -import Control.Exception.Safe as Safe -import qualified Control.Eff.ExceptionExtra as ExcExtra () -import Control.Concurrent.STM as STM -import Control.Concurrent (yield) -import qualified Control.Concurrent.Async as Async -import Control.Concurrent.Async (Async(..)) -import Control.Eff -import Control.Eff.Extend -import Control.Eff.Concurrent.Process -import Control.Eff.Lift -import Control.Eff.Log -import Control.Eff.Reader.Strict as Reader -import Control.Lens -import Control.Monad ( when - , void - , (>=>) - ) -import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Data.Default -import Data.Dynamic -import Data.Foldable -import Data.Kind ( ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Set ( Set ) -import qualified Data.Set as Set -import Data.Maybe -import Data.Sequence ( Seq(..) ) -import qualified Data.Sequence as Seq -import GHC.Stack -import Text.Printf -import System.Timeout +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 -- * Process Types -- | A message queue of a process, contains the actual queue and maybe an --- exit reason. -data MessageQ = MessageQ { _incomingMessages :: Seq Dynamic - , _shutdownRequests :: Maybe SomeExitReason - } +-- exit reason. The message queue is backed by a 'Seq' sequence with 'Dynamic' values. +data MessageQ = MessageQ + { _incomingMessages :: Seq Dynamic + , _shutdownRequests :: Maybe SomeExitReason + } -instance Default MessageQ where def = MessageQ def def +instance Default MessageQ where + def = MessageQ def def makeLenses ''MessageQ -- | Return any '_shutdownRequests' from a 'MessageQ' in a 'TVar' and -- reset the '_shutdownRequests' field to 'Nothing' in the 'TVar'. -tryTakeNextShutdownRequestSTM - :: TVar MessageQ -> STM (Maybe SomeExitReason) +tryTakeNextShutdownRequestSTM :: TVar MessageQ -> STM (Maybe SomeExitReason) tryTakeNextShutdownRequestSTM mqVar = do mq <- readTVar mqVar - when (isJust (mq^.shutdownRequests)) - (writeTVar mqVar (mq & shutdownRequests .~ Nothing)) - return (mq^.shutdownRequests) - + when (isJust (mq ^. shutdownRequests)) (writeTVar mqVar (mq & shutdownRequests .~ Nothing)) + return (mq ^. shutdownRequests) --- | Information about a process, needed to implement 'MessagePassing' and --- 'Process' handlers. The message queue is backed by a 'STM.TQueue' and contains --- 'MessageQEntry' values. -data ProcessInfo = - ProcessInfo { _processId :: ProcessId - , _processState :: TVar ProcessState - , _messageQ :: TVar MessageQ - , _processLinks :: TVar (Set ProcessId) - } +-- | Information about a process, needed to implement +-- 'Process' handlers. The message queue is backed by a 'STM.TVar' that contains +-- a 'MessageQ'. +data ProcessInfo = ProcessInfo + { _processId :: ProcessId + , _processState :: TVar ProcessState + , _messageQ :: TVar MessageQ + , _processLinks :: TVar (Set ProcessId) + } makeLenses ''ProcessInfo -- * Scheduler Types -- | Contains all process info'elements, as well as the state needed to --- implement inter process communication. It contains also a 'LogChannel' to --- which the logs of all processes are forwarded to. -data SchedulerState = - SchedulerState { _nextPid :: TVar ProcessId - , _processTable :: TVar (Map ProcessId ProcessInfo) - , _processCancellationTable - :: TVar (Map ProcessId - (Async (ExitReason 'NoRecovery))) - , _processMonitors :: TVar (Set (MonitorReference, ProcessId)) - , _nextMonitorIndex :: TVar Int - -- Set of monitors and monitor owners - } +-- implement inter process communication. +data SchedulerState = SchedulerState + { _nextPid :: TVar ProcessId + , _processTable :: TVar (Map ProcessId ProcessInfo) + , _processCancellationTable :: TVar (Map ProcessId (Async (ExitReason 'NoRecovery))) + , _processMonitors :: TVar (Set (MonitorReference, ProcessId)) -- ^ Set of monitors and monitor owners + , _nextMonitorIndex :: TVar Int + } makeLenses ''SchedulerState --- | Add monitor: If the process is dead, enqueue a ProcessDown message into the +-- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the -- owners message queue addMonitoring :: ProcessId -> ProcessId -> SchedulerState -> STM MonitorReference addMonitoring target owner schedulerState = do - mi <- readTVar (schedulerState ^. nextMonitorIndex) - modifyTVar' (schedulerState ^. nextMonitorIndex) (+1) - let mref = MonitorReference mi target + aNewMonitorIndex <- readTVar (schedulerState ^. nextMonitorIndex) + modifyTVar' (schedulerState ^. nextMonitorIndex) (+ 1) + let monitorRef = MonitorReference aNewMonitorIndex target when (target /= owner) $ do pt <- readTVar (schedulerState ^. processTable) - if Map.member target pt then - modifyTVar' (schedulerState ^. processMonitors) (Set.insert (mref, owner)) - else - let pdown = (ProcessDown mref (SomeExitReason (ProcessNotRunning target))) - in enqueueMessageOtherProcess owner (toDyn pdown) schedulerState - return mref + 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 + return monitorRef removeMonitoring :: MonitorReference -> SchedulerState -> STM () -removeMonitoring mref schedulerState = - modifyTVar' (schedulerState ^. processMonitors) - (Set.filter (\(ref,_) -> ref /= mref)) +removeMonitoring monitorRef schedulerState = + modifyTVar' (schedulerState ^. processMonitors) (Set.filter (\(ref, _) -> ref /= monitorRef)) triggerAndRemoveMonitor :: ProcessId -> SomeExitReason -> SchedulerState -> STM () triggerAndRemoveMonitor downPid reason schedulerState = do @@ -138,76 +123,60 @@ traverse_ go monRefs where go (mr, owner) = - when (monitoredProcess mr == downPid) (do - let pdown = ProcessDown mr reason - enqueueMessageOtherProcess owner (toDyn pdown) schedulerState - removeMonitoring mr schedulerState) + when + (monitoredProcess mr == downPid) + (do let processDownMessage = ProcessDown mr reason + enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState + removeMonitoring mr schedulerState) -- * Process Implementation - instance Show ProcessInfo where - show p = "process info: " ++ show (p ^. processId) + show p = "process info: " ++ show (p ^. processId) -- | 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 - :: (HasLogging IO SchedulerIO, HasCallStack) - => Eff SchedulerIO () - -> Eff LoggingAndIO () +withNewSchedulerState :: (HasCallStack) => Eff SchedulerIO () -> Eff LoggingAndIo () withNewSchedulerState mainProcessAction = - Safe.bracketWithError + 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 + 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)) + 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")))) + (\runS -> + timeout + 5000000 + (Async.mapConcurrently + (\a -> do + Async.cancel a + runS (logNotice ("process cancelled: " ++ 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'. @@ -218,491 +187,405 @@ -- | Type class constraint to indicate that an effect union contains the -- effects required by every process and the scheduler implementation itself. -type HasSchedulerIO r = ( HasCallStack - , Lifted IO r - , SchedulerIO <:: r - ) +type HasSchedulerIO r = (HasCallStack, Lifted IO r, SchedulerIO <:: r) -- | The concrete list of 'Eff'ects for this scheduler implementation. -type SchedulerIO = ( Reader SchedulerState : LoggingAndIO) - --- | Basic effects: 'Logs' 'LogMessage' and 'Lift' IO -type LoggingAndIO = - '[ Logs LogMessage - , LogWriterReader LogMessage IO - , Lift IO - ] +type SchedulerIO = (Reader SchedulerState : LoggingAndIo) -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMain :: HasCallStack => Eff InterruptableProcEff () -> IO () -defaultMain c = - withAsyncLogChannel (1024 :: Int) - (multiMessageLogWriter ($ printLogMessage)) - (handleLoggingAndIO_ (schedule c)) +defaultMain = defaultMainWithLogWriter consoleLogWriter -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. -defaultMainWithLogChannel - :: HasCallStack => Eff InterruptableProcEff () -> LogChannel LogMessage -> IO () -defaultMainWithLogChannel = handleLoggingAndIO_ . schedule - --- | A 'SchedulerProxy' for 'SchedulerIO' -forkIoScheduler :: SchedulerProxy SchedulerIO -forkIoScheduler = SchedulerProxy - +defaultMainWithLogWriter :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO () +defaultMainWithLogWriter lw = + runLift . withSomeLogging . withAsyncLogging (1024 :: Int) lw . schedule --- ** MessagePassing execution +-- ** Process Execution -handleProcess - :: (HasLogging IO SchedulerIO, HasCallStack) - => ProcessInfo - -> Eff ProcEff (ExitReason 'NoRecovery) - -> Eff SchedulerIO (ExitReason 'NoRecovery) -handleProcess myProcessInfo = - handle_relay_s - 0 - (const return) - (\ !nextRef !request k -> - stepProcessInterpreter nextRef request k return - ) - where - myPid = myProcessInfo ^. processId - myProcessStateVar = myProcessInfo ^. processState - setMyProcessState = lift . atomically . setMyProcessStateSTM +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 = - + 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 -- 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) + = + tryTakeNextShutdownRequest >>= + maybe noShutdownRequested (either onShutdownRequested onInterruptRequested . fromSomeExitReason) where - tryTakeNextShutdownRequest = - lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar)) - + tryTakeNextShutdownRequest = lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar)) onShutdownRequested shutdownRequest = do - logDebug ("shutdown requested: " ++ show shutdownRequest) - setMyProcessState ProcessShuttingDown - interpretRequestAfterShutdownRequest - (diskontinueWith diskontinue) - shutdownRequest - request - + 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 - + 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 - + 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 procInfosVar = schedulerState^.processTable - lift $ atomically $ do - procInfos <- readTVar procInfosVar - traverse_ - (\toProcInfo -> - modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid)) - (procInfos ^. at toPid) - modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid) - - interpretGetProcessState !toPid = do - setMyProcessState ProcessBusy - schedulerState <- getSchedulerState - let procInfosVar = schedulerState^.processTable - lift $ atomically $ do - procInfos <- readTVar procInfosVar - traverse (\toProcInfo -> readTVar (toProcInfo ^. processState)) - (procInfos ^. at toPid) - - interpretLink !toPid = do - setMyProcessState ProcessBusyLinking - schedulerState <- getSchedulerState - let procInfosVar = schedulerState^.processTable - lift $ atomically $ do - procInfos <- readTVar procInfosVar - case procInfos ^. 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 :: + 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' --- effect and a 'LogChannel' for concurrent logging. -schedule - :: (HasLogging IO SchedulerIO, HasCallStack) - => Eff InterruptableProcEff () - -> Eff LoggingAndIO () +-- effect for concurrent logging. +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 + 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 -spawnNewProcess - :: (HasLogging IO SchedulerIO, HasCallStack) +spawnNewProcess :: + (HasCallStack) => Maybe ProcessInfo -> Eff ProcEff () -> Eff SchedulerIO (ProcessId, Async (ExitReason 'NoRecovery)) -spawnNewProcess mlinkedParent mfa = do +spawnNewProcess mLinkedParent mfa = do schedulerState <- getSchedulerState procInfo <- allocateProcInfo schedulerState - traverse_ (linkToParent procInfo) mlinkedParent + traverse_ (linkToParent procInfo) mLinkedParent procAsync <- doForkProc procInfo schedulerState return (procInfo ^. processId, procAsync) - where + 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) - + lift $ + atomically $ do + modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid) + modifyTVar' (parent ^. processLinks) (Set.insert toPid) allocateProcInfo schedulerState = - lift (atomically (do - let nextPidVar = schedulerState ^. nextPid - processInfosVar = schedulerState ^. processTable - pid <- readTVar nextPidVar - modifyTVar' nextPidVar (+1) - procInfo <- newProcessInfo pid - modifyTVar' processInfosVar (at pid ?~ procInfo) - return procInfo - )) - + 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 traverseLogMessages - (traverse setLogMessageThreadId - >=> traverse (return . addProcessId)) - + 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 + lift $ atomically $ triggerAndRemoveMonitor pid (SomeExitReason reason) schedulerState let exitSeverity = toExitSeverity reason sendIt !linkedPid = do let msg = SomeExitReason (LinkedProcessCrashed pid) - lift $ atomically $ do - procInfos <- readTVar (schedulerState ^. processTable) - let mLinkedProcInfo = procInfos ^? at linkedPid . _Just - 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)) + 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 - + 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 = - restoreM =<< liftBaseWith + control (\inScheduler -> do - let cancellationsVar = schedulerState ^. processCancellationTable - processInfosVar = schedulerState ^. processTable - pid = procInfo ^. processId - procAsync <- Async.async ( - inScheduler (logAppendProcInfo pid - (Safe.bracketWithError - (logDebug "enter process") - (\mExc () -> do - lift (atomically - (do modifyTVar' processInfosVar (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) + 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 + 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 (return ()) - (\toProcessTable -> do - modifyTVar' (toProcessTable ^. messageQ ) (incomingMessages %~ (:|> msg)) - return ()) + view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= + maybe + (return ()) + (\toProcessTable -> do + 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 (return ()) - (\toProcessTable -> do - modifyTVar' (toProcessTable ^. messageQ ) (shutdownRequests ?~ msg) - return ()) + view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= + maybe + (return ()) + (\toProcessTable -> do + modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg) + return ()) diff --git a/src/Control/Eff/Concurrent/Process/Interactive.hs b/src/Control/Eff/Concurrent/Process/Interactive.hs --- a/src/Control/Eff/Concurrent/Process/Interactive.hs +++ b/src/Control/Eff/Concurrent/Process/Interactive.hs @@ -38,7 +38,6 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Eff -import Control.Eff.Lift import Control.Eff.Concurrent.Api import Control.Eff.Concurrent.Api.Client import Control.Eff.Concurrent.Process 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 @@ -6,14 +6,11 @@ , scheduleMonadIOEff , scheduleIOWithLogging , defaultMainSingleThreaded - , singleThreadedIoScheduler ) where import Control.Concurrent ( yield ) -import Control.DeepSeq import Control.Eff -import Control.Eff.Lift import Control.Eff.Extend import Control.Eff.Concurrent.Process import Control.Eff.Log @@ -22,6 +19,7 @@ ) import Control.Monad ( void , when + , foldM ) import Control.Monad.IO.Class import qualified Data.Sequence as Seq @@ -34,6 +32,7 @@ import Data.Foldable import Data.Monoid import qualified Control.Monad.State.Strict as State +import Data.Function (fix) -- ----------------------------------------------------------------------------- -- STS @@ -45,7 +44,7 @@ , _msgQs :: !(Map.Map ProcessId (Seq Dynamic)) , _monitors :: !(Set.Set (MonitorReference, ProcessId)) , _processLinks :: !(Set.Set (ProcessId, ProcessId)) - , _runEff :: (forall a . Eff r a -> m a) + , _runEff :: forall a . Eff r a -> m a , _yieldEff :: m () } @@ -65,7 +64,7 @@ (foldMap (\(pid, msgs) -> Endo (showString " " . shows pid . showString ": ") - <> foldMap (\m -> Endo (shows (dynTypeRep m))) (toList msgs) + <> foldMap (Endo . shows . dynTypeRep) (toList msgs) ) (sts ^.. msgQs . itraversed . withIndex) ) @@ -84,7 +83,7 @@ incRef sts = (sts ^. nextRef, sts & nextRef %~ (+ 1)) enqueueMsg :: ProcessId -> Dynamic -> STS r m -> STS r m -enqueueMsg toPid msg = msgQs . at toPid . _Just %~ (:|> msg) +enqueueMsg toPid msg = msgQs . ix toPid %~ (:|> msg) newProcessQ :: Maybe ProcessId -> STS r m -> (ProcessId, STS r m) newProcessQ parentLink sts = @@ -104,35 +103,37 @@ receiveMsg :: ProcessId -> MessageSelector a -> STS m r -> Maybe (Maybe (a, STS m r)) -receiveMsg pid messageSelector sts = case sts ^. msgQs . at pid of - Nothing -> Nothing - Just msgQ -> Just $ case partitionMessages msgQ Empty of +receiveMsg pid messageSelector sts = + case sts ^. msgQs . at pid of Nothing -> Nothing - Just (result, otherMessages) -> - Just (result, sts & msgQs . at pid . _Just .~ otherMessages) - where - partitionMessages Empty _acc = Nothing - partitionMessages (m :<| msgRest) acc = maybe - (partitionMessages msgRest (acc :|> m)) - (\res -> Just (res, acc Seq.>< msgRest)) - (runMessageSelector messageSelector m) + Just msgQ -> + Just $ + case partitionMessages msgQ Empty of + Nothing -> Nothing + Just (result, otherMessages) -> Just (result, sts & msgQs . ix pid .~ otherMessages) + where + partitionMessages Empty _acc = Nothing + partitionMessages (m :<| msgRest) acc = + maybe + (partitionMessages msgRest (acc :|> m)) + (\res -> Just (res, acc Seq.>< msgRest)) + (runMessageSelector messageSelector m) -- | Add monitor: If the process is dead, enqueue a ProcessDown message into the -- owners message queue addMonitoring :: ProcessId -> ProcessId -> STS m r -> (MonitorReference, STS m r) -addMonitoring owner target = State.runState $ do - mi <- State.state incRef - let mref = MonitorReference mi target - when (target /= owner) $ do - pt <- use msgQs - if Map.member target pt - then monitors %= Set.insert (mref, owner) - else - let pdown = - (ProcessDown mref (SomeExitReason (ProcessNotRunning target))) - in State.modify' (enqueueMsg owner (toDyn pdown)) - return mref +addMonitoring owner target = + State.runState $ do + mi <- State.state incRef + let mref = MonitorReference mi target + when (target /= owner) $ do + pt <- use msgQs + if Map.member target pt + then monitors %= Set.insert (mref, owner) + else let pdown = ProcessDown mref (SomeExitReason (ProcessNotRunning target)) + in State.modify' (enqueueMsg owner (toDyn pdown)) + return mref removeMonitoring :: MonitorReference -> STS m r -> STS m r removeMonitoring mref = monitors %~ Set.filter (\(ref, _) -> ref /= mref) @@ -177,16 +178,16 @@ -- Meat Of The Thing -- ----------------------------------------------------------------------------- --- | Like 'schedule' but /pure/. The @yield@ effect is just @return ()@. +-- | Like 'scheduleIO' but /pure/. The @yield@ effect is just @return ()@. -- @schedulePure == runIdentity . 'scheduleM' (Identity . run) (return ())@ -- -- @since 0.3.0.2 schedulePure - :: Eff (InterruptableProcess '[Logs LogMessage]) a + :: Eff (InterruptableProcess '[Logs, LogWriterReader PureLogWriter]) a -> Either (ExitReason 'NoRecovery) a -schedulePure e = run (scheduleM ignoreLogs (return ()) e) +schedulePure e = run (scheduleM (withSomeLogging @PureLogWriter) (return ()) e) --- | Invoke 'schedule' with @lift 'Control.Concurrent.yield'@ as yield effect. +-- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleIO runEff == 'scheduleM' (runLift . runEff) (liftIO 'yield')@ -- -- @since 0.4.0.0 @@ -197,7 +198,7 @@ -> m (Either (ExitReason 'NoRecovery) a) scheduleIO r = scheduleM (runLift . r) (liftIO yield) --- | Invoke 'schedule' with @lift 'Control.Concurrent.yield'@ as yield effect. +-- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleMonadIOEff == 'scheduleM' id (liftIO 'yield')@ -- -- @since 0.3.0.2 @@ -213,22 +214,22 @@ -- -- Log messages are evaluated strict. -- --- @scheduleIOWithLogging == 'run' . 'captureLogs' . 'schedule' (return ())@ +-- @scheduleIOWithLogging == 'scheduleIO' . 'withLogging'@ -- -- @since 0.4.0.0 scheduleIOWithLogging - :: (NFData l) - => LogWriter l IO - -> Eff (InterruptableProcess '[Logs l, LogWriterReader l IO, Lift IO]) a + :: HasCallStack + => LogWriter IO + -> Eff (InterruptableProcess LoggingAndIo) a -> IO (Either (ExitReason 'NoRecovery) a) -scheduleIOWithLogging h = scheduleIO (writeLogs h) +scheduleIOWithLogging h = scheduleIO (withLogging h) -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. -- -- Execute the __main__ 'Process' and all the other processes 'spawn'ed by it in the -- current thread concurrently, using a co-routine based, round-robin --- scheduler. If a process exits with 'exitNormally', 'exitWithError', --- 'raiseError' or is killed by another process @Left ...@ is returned. +-- scheduler. If a process exits with eg.g 'exitNormally' or 'exitWithError' +-- or is killed by another process @Left ...@ is returned. -- Otherwise, the result will be wrapped in a @Right@. -- -- Every time a process _yields_ the effects are evaluated down to the a value @@ -328,25 +329,28 @@ => (forall a . Eff r a -> m a) -> Eff (ConsProcess r) v -> m (OnYield r v) -runAsCoroutinePure r = r . handle_relay (return . OnDone) cont +runAsCoroutinePure r = r . fix (handle_relay' cont (return . OnDone)) where - cont :: Process r x -> (x -> Eff r (OnYield r v)) -> Eff r (OnYield r v) - cont FlushMessages k = return (OnFlushMessages k) - cont YieldProcess k = return (OnYield k) - cont SelfPid k = return (OnSelf k) - cont (Spawn e ) k = return (OnSpawn False e k) - cont (SpawnLink e ) k = return (OnSpawn True e k) - cont (Shutdown !sr ) _k = return (OnShutdown sr) - cont (SendMessage !tp !msg ) k = return (OnSend tp msg k) - cont (ReceiveSelectedMessage f ) k = return (OnRecv f k) - cont (GetProcessState !tp) k = return (OnGetProcessState tp k) - cont (SendInterrupt !tp !er ) k = return (OnSendInterrupt tp er k) - cont (SendShutdown !pid !sr ) k = return (OnSendShutdown pid sr k) - cont MakeReference k = return (OnMakeReference k) - cont (Monitor !pid) k = return (OnMonitor pid k) - cont (Demonitor !ref) k = return (OnDemonitor ref k) - cont (Link !pid) k = return (OnLink pid k) - cont (Unlink !pid) k = return (OnUnlink pid k) + cont :: (Eff (ConsProcess r) v -> Eff r (OnYield r v)) + -> Arrs (ConsProcess r) x v + -> Process r x + -> Eff r (OnYield r v) + cont k q FlushMessages = return (OnFlushMessages (k . qApp q)) + cont k q YieldProcess = return (OnYield (k . qApp q)) + cont k q SelfPid = return (OnSelf (k . qApp q)) + cont k q (Spawn e ) = return (OnSpawn False e (k . qApp q)) + cont k q (SpawnLink e ) = return (OnSpawn True e (k . qApp q)) + cont _ _ (Shutdown !sr ) = return (OnShutdown sr) + cont k q (SendMessage !tp !msg ) = return (OnSend tp msg (k . qApp q)) + cont k q (ReceiveSelectedMessage f ) = return (OnRecv f (k . qApp q)) + cont k q (GetProcessState !tp) = return (OnGetProcessState tp (k . qApp q)) + cont k q (SendInterrupt !tp !er ) = return (OnSendInterrupt tp er (k . qApp q)) + cont k q (SendShutdown !pid !sr ) = return (OnSendShutdown pid sr (k . qApp q)) + cont k q MakeReference = return (OnMakeReference (k . qApp q)) + cont k q (Monitor !pid) = return (OnMonitor pid (k . qApp q)) + cont k q (Demonitor !ref) = return (OnDemonitor ref (k . qApp q)) + cont k q (Link !pid) = return (OnLink pid (k . qApp q)) + cont k q (Unlink !pid) = return (OnUnlink pid (k . qApp q)) -- | Internal 'Process' handler function. handleProcess @@ -358,207 +362,166 @@ return $ Left (NotRecovered (ProcessError "no main process")) handleProcess sts allProcs@((!processState, !pid) :<| rest) = - let handleExit res = if pid == 0 - then return res - else do - let (downPids, stsNew) = removeLinksTo pid sts - linkedPids = filter (/= pid) downPids - reason = LinkedProcessCrashed pid - unlinkLoop [] ps = return ps - unlinkLoop (dPid : dPidRest) ps = do - ps' <- sendInterruptToOtherPid dPid reason ps - unlinkLoop dPidRest ps' - let allProcsWithoutPid = Seq.filter (\(_, p) -> p /= pid) rest - nextTargets <- unlinkLoop linkedPids allProcsWithoutPid - handleProcess - (dropMsgQ - pid - (triggerAndRemoveMonitor - pid - (either SomeExitReason (const (SomeExitReason ExitNormally)) res - ) - stsNew - ) - ) - nextTargets - in - case processState of - OnDone r -> handleExit (Right r) - - OnShutdown e -> handleExit (Left e) - - OnInterrupt e k -> do - nextK <- diskontinue sts k e - handleProcess sts (rest :|> (nextK, pid)) - - OnSendInterrupt targetPid sr k -> doSendInterrupt targetPid sr k - - OnSendShutdown targetPid sr k -> do - let allButTarget = - Seq.filter (\(_, e) -> e /= pid && e /= targetPid) allProcs - targets = Seq.filter (\(_, e) -> e == targetPid) allProcs - suicide = targetPid == pid - if suicide - then handleExit (Left sr) + let handleExit res = + if pid == 0 + then return res else do - let deliverTheGoodNews (targetState, tPid) = do - nextTargetState <- case targetState of - OnSendInterrupt _ _ _tk -> return (OnShutdown sr) - OnSendShutdown _ _ _tk -> return (OnShutdown sr) - OnFlushMessages _tk -> return (OnShutdown sr) - OnYield _tk -> return (OnShutdown sr) - OnSelf _tk -> return (OnShutdown sr) - OnSend _ _ _tk -> return (OnShutdown sr) - OnRecv _ _tk -> return (OnShutdown sr) - OnSpawn _ _ _tk -> return (OnShutdown sr) - OnDone x -> return (OnDone x) - OnGetProcessState _ _tk -> return (OnShutdown sr) - OnShutdown sr' -> return (OnShutdown sr') - OnInterrupt _er _tk -> return (OnShutdown sr) - OnMakeReference _tk -> return (OnShutdown sr) - OnMonitor _ _tk -> return (OnShutdown sr) - OnDemonitor _ _tk -> return (OnShutdown sr) - OnLink _ _tk -> return (OnShutdown sr) - OnUnlink _ _tk -> return (OnShutdown sr) - return (nextTargetState, tPid) - nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets - nextK <- kontinue sts k () - handleProcess sts - (allButTarget Seq.>< (nextTargets :|> (nextK, pid))) - - OnSelf k -> do - nextK <- kontinue sts k pid - handleProcess sts (rest :|> (nextK, pid)) - - OnMakeReference k -> do - let (ref, stsNext) = incRef sts - nextK <- kontinue sts k ref - handleProcess stsNext (rest :|> (nextK, pid)) - - OnYield k -> do - sts ^. yieldEff - nextK <- kontinue sts k () - handleProcess sts (rest :|> (nextK, pid)) - - OnSend toPid msg k -> do - nextK <- kontinue sts k () - handleProcess (enqueueMsg toPid msg sts) (rest :|> (nextK, pid)) - - OnGetProcessState toPid k -> do - nextK <- kontinue sts k (getProcessState toPid sts) - handleProcess sts (rest :|> (nextK, pid)) - - OnSpawn link f k -> do - let (newPid, newSts) = - newProcessQ (if link then Just pid else Nothing) sts - fk <- runAsCoroutinePure (newSts ^. runEff) (f >> exitNormally) - nextK <- kontinue newSts k newPid - handleProcess newSts (rest :|> (fk, newPid) :|> (nextK, pid)) - - OnFlushMessages k -> do - let (msgs, newSts) = flushMsgs pid sts - nextK <- kontinue newSts k msgs - handleProcess newSts (rest :|> (nextK, pid)) - - recv@(OnRecv messageSelector k) -> - case receiveMsg pid messageSelector sts of - Nothing -> do - nextK <- diskontinue - sts - k - (ProcessError (show pid ++ " has no message queue")) - - handleProcess sts (rest :|> (nextK, pid)) - Just Nothing -> if Seq.length rest == 0 - then do - nextK <- diskontinue sts - k - (ProcessError (show pid ++ " deadlocked")) + let (downPids, stsNew) = removeLinksTo pid sts + linkedPids = filter (/= pid) downPids + reason = LinkedProcessCrashed pid + unlinkLoop dPidRest ps = foldM (\ps' dPid -> sendInterruptToOtherPid dPid reason ps') ps dPidRest + let allProcsWithoutPid = Seq.filter (\(_, p) -> p /= pid) rest + nextTargets <- unlinkLoop linkedPids allProcsWithoutPid + handleProcess + (dropMsgQ + pid + (triggerAndRemoveMonitor pid (either SomeExitReason (const (SomeExitReason ExitNormally)) res) stsNew)) + nextTargets + in case processState of + OnDone r -> handleExit (Right r) + OnShutdown e -> handleExit (Left e) + OnInterrupt e k -> do + nextK <- diskontinue sts k e + handleProcess sts (rest :|> (nextK, pid)) + OnSendInterrupt targetPid sr k -> doSendInterrupt targetPid sr k + OnSendShutdown targetPid sr k -> do + let allButTarget = Seq.filter (\(_, e) -> e /= pid && e /= targetPid) allProcs + targets = Seq.filter (\(_, e) -> e == targetPid) allProcs + suicide = targetPid == pid + if suicide + then handleExit (Left sr) + else do + let deliverTheGoodNews (targetState, tPid) = do + nextTargetState <- + case targetState of + OnSendInterrupt _ _ _tk -> return (OnShutdown sr) + OnSendShutdown _ _ _tk -> return (OnShutdown sr) + OnFlushMessages _tk -> return (OnShutdown sr) + OnYield _tk -> return (OnShutdown sr) + OnSelf _tk -> return (OnShutdown sr) + OnSend _ _ _tk -> return (OnShutdown sr) + OnRecv _ _tk -> return (OnShutdown sr) + OnSpawn _ _ _tk -> return (OnShutdown sr) + OnDone x -> return (OnDone x) + OnGetProcessState _ _tk -> return (OnShutdown sr) + OnShutdown sr' -> return (OnShutdown sr') + OnInterrupt _er _tk -> return (OnShutdown sr) + OnMakeReference _tk -> return (OnShutdown sr) + OnMonitor _ _tk -> return (OnShutdown sr) + OnDemonitor _ _tk -> return (OnShutdown sr) + OnLink _ _tk -> return (OnShutdown sr) + OnUnlink _ _tk -> return (OnShutdown sr) + return (nextTargetState, tPid) + nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets + nextK <- kontinue sts k () + handleProcess sts (allButTarget Seq.>< (nextTargets :|> (nextK, pid))) + OnSelf k -> do + nextK <- kontinue sts k pid + handleProcess sts (rest :|> (nextK, pid)) + OnMakeReference k -> do + let (ref, stsNext) = incRef sts + nextK <- kontinue sts k ref + handleProcess stsNext (rest :|> (nextK, pid)) + OnYield k -> do + sts ^. yieldEff + nextK <- kontinue sts k () + handleProcess sts (rest :|> (nextK, pid)) + OnSend toPid msg k -> do + nextK <- kontinue sts k () + handleProcess (enqueueMsg toPid msg sts) (rest :|> (nextK, pid)) + OnGetProcessState toPid k -> do + nextK <- kontinue sts k (getProcessState toPid sts) + handleProcess sts (rest :|> (nextK, pid)) + OnSpawn link f k -> do + let (newPid, newSts) = + newProcessQ + (if link + then Just pid + else Nothing) + sts + fk <- runAsCoroutinePure (newSts ^. runEff) (f >> exitNormally) + nextK <- kontinue newSts k newPid + handleProcess newSts (rest :|> (fk, newPid) :|> (nextK, pid)) + OnFlushMessages k -> do + let (msgs, newSts) = flushMsgs pid sts + nextK <- kontinue newSts k msgs + handleProcess newSts (rest :|> (nextK, pid)) + recv@(OnRecv messageSelector k) -> + case receiveMsg pid messageSelector sts of + Nothing -> do + nextK <- diskontinue sts k (ProcessError (show pid ++ " has no message queue")) handleProcess sts (rest :|> (nextK, pid)) - else handleProcess sts (rest :|> (recv, pid)) - Just (Just (result, newSts)) -> do - nextK <- kontinue newSts k result - handleProcess newSts (rest :|> (nextK, pid)) - - OnMonitor toPid k -> do - let (ref, stsNew) = addMonitoring pid toPid sts - nextK <- kontinue stsNew k ref - handleProcess stsNew (rest :|> (nextK, pid)) - - OnDemonitor monRef k -> do - let stsNew = removeMonitoring monRef sts - nextK <- kontinue stsNew k () - handleProcess stsNew (rest :|> (nextK, pid)) - - OnLink toPid k -> do - let (downInterrupts, stsNew) = addLink pid toPid sts - nextK <- case downInterrupts of - Nothing -> kontinue stsNew k () - Just i -> diskontinue stsNew k i - handleProcess stsNew (rest :|> (nextK, pid)) - - OnUnlink toPid k -> do - let (_, stsNew) = removeLinksTo toPid sts - nextK <- kontinue stsNew k () - handleProcess stsNew (rest :|> (nextK, pid)) - where - doSendInterrupt targetPid sr k = do - let suicide = targetPid == pid - if suicide - then do - nextK <- diskontinue sts k sr - handleProcess sts (rest :|> (nextK, pid)) - else do - nextTargets <- sendInterruptToOtherPid targetPid sr rest - nextK <- kontinue sts k () - handleProcess sts (nextTargets :|> (nextK, pid)) - - sendInterruptToOtherPid targetPid sr procs = do - let allButTarget = Seq.filter (\(_, e) -> e /= targetPid) procs - targets = Seq.filter (\(_, e) -> e == targetPid) procs - deliverTheGoodNews (targetState, tPid) = do - nextTargetState <- case targetState of - OnSendInterrupt _ _ tk -> tk (Interrupted sr) - OnSendShutdown _ _ tk -> tk (Interrupted sr) - OnFlushMessages tk -> tk (Interrupted sr) - OnYield tk -> tk (Interrupted sr) - OnSelf tk -> tk (Interrupted sr) - OnSend _ _ tk -> tk (Interrupted sr) - OnRecv _ tk -> tk (Interrupted sr) - OnSpawn _ _ tk -> tk (Interrupted sr) - OnDone x -> return (OnDone x) - OnGetProcessState _ tk -> tk (Interrupted sr) - OnShutdown sr' -> return (OnShutdown sr') - OnInterrupt er tk -> tk (Interrupted er) - OnMakeReference tk -> tk (Interrupted sr) - OnMonitor _ tk -> tk (Interrupted sr) - OnDemonitor _ tk -> tk (Interrupted sr) - OnLink _ tk -> tk (Interrupted sr) - OnUnlink _ tk -> tk (Interrupted sr) - return (nextTargetState, tPid) - nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets - return (nextTargets Seq.>< allButTarget) - --- | The concrete list of 'Eff'ects for running this pure scheduler on @IO@ and --- with string logging. -type LoggingAndIo = '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO] - --- | A 'SchedulerProxy' for 'LoggingAndIo'. -singleThreadedIoScheduler :: SchedulerProxy LoggingAndIo -singleThreadedIoScheduler = SchedulerProxy + Just Nothing -> + if Seq.length rest == 0 + then do + nextK <- diskontinue sts k (ProcessError (show pid ++ " deadlocked")) + handleProcess sts (rest :|> (nextK, pid)) + else handleProcess sts (rest :|> (recv, pid)) + Just (Just (result, newSts)) -> do + nextK <- kontinue newSts k result + handleProcess newSts (rest :|> (nextK, pid)) + OnMonitor toPid k -> do + let (ref, stsNew) = addMonitoring pid toPid sts + nextK <- kontinue stsNew k ref + handleProcess stsNew (rest :|> (nextK, pid)) + OnDemonitor monRef k -> do + let stsNew = removeMonitoring monRef sts + nextK <- kontinue stsNew k () + handleProcess stsNew (rest :|> (nextK, pid)) + OnLink toPid k -> do + let (downInterrupts, stsNew) = addLink pid toPid sts + nextK <- + case downInterrupts of + Nothing -> kontinue stsNew k () + Just i -> diskontinue stsNew k i + handleProcess stsNew (rest :|> (nextK, pid)) + OnUnlink toPid k -> do + let (_, stsNew) = removeLinksTo toPid sts + nextK <- kontinue stsNew k () + handleProcess stsNew (rest :|> (nextK, pid)) + where + doSendInterrupt targetPid sr k = do + let suicide = targetPid == pid + if suicide + then do + nextK <- diskontinue sts k sr + handleProcess sts (rest :|> (nextK, pid)) + else do + nextTargets <- sendInterruptToOtherPid targetPid sr rest + nextK <- kontinue sts k () + handleProcess sts (nextTargets :|> (nextK, pid)) + sendInterruptToOtherPid targetPid sr procs = do + let allButTarget = Seq.filter (\(_, e) -> e /= targetPid) procs + targets = Seq.filter (\(_, e) -> e == targetPid) procs + deliverTheGoodNews (targetState, tPid) = do + nextTargetState <- + case targetState of + OnSendInterrupt _ _ tk -> tk (Interrupted sr) + OnSendShutdown _ _ tk -> tk (Interrupted sr) + OnFlushMessages tk -> tk (Interrupted sr) + OnYield tk -> tk (Interrupted sr) + OnSelf tk -> tk (Interrupted sr) + OnSend _ _ tk -> tk (Interrupted sr) + OnRecv _ tk -> tk (Interrupted sr) + OnSpawn _ _ tk -> tk (Interrupted sr) + OnDone x -> return (OnDone x) + OnGetProcessState _ tk -> tk (Interrupted sr) + OnShutdown sr' -> return (OnShutdown sr') + OnInterrupt er tk -> tk (Interrupted er) + OnMakeReference tk -> tk (Interrupted sr) + OnMonitor _ tk -> tk (Interrupted sr) + OnDemonitor _ tk -> tk (Interrupted sr) + OnLink _ tk -> tk (Interrupted sr) + OnUnlink _ tk -> tk (Interrupted sr) + return (nextTargetState, tPid) + nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets + return (nextTargets Seq.>< allButTarget) --- | Execute a 'Process' using 'schedule' on top of 'Lift' @IO@ and 'Logs' +-- | Execute a 'Process' using 'scheduleM' on top of 'Lift' @IO@ and 'withLogging' -- @String@ effects. -defaultMainSingleThreaded - :: HasCallStack - => Eff - ( InterruptableProcess - '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO] - ) - () - -> IO () +defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess LoggingAndIo) () -> IO () defaultMainSingleThreaded = void . runLift - . writeLogs (multiMessageLogWriter ($ printLogMessage)) + . withLogging consoleLogWriter . scheduleMonadIOEff diff --git a/src/Control/Eff/Concurrent/Process/Timer.hs b/src/Control/Eff/Concurrent/Process/Timer.hs --- a/src/Control/Eff/Concurrent/Process/Timer.hs +++ b/src/Control/Eff/Concurrent/Process/Timer.hs @@ -20,7 +20,6 @@ import Control.Eff.Concurrent.Process import Control.Concurrent -import Control.Eff.Lift import Control.Eff import Control.DeepSeq import Control.Monad.IO.Class diff --git a/src/Control/Eff/ExceptionExtra.hs b/src/Control/Eff/ExceptionExtra.hs --- a/src/Control/Eff/ExceptionExtra.hs +++ b/src/Control/Eff/ExceptionExtra.hs @@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} --- | Add-ons to 'Control.Eff.Exception' and 'Control.Excepion' +-- | Add-ons to 'Control.Eff.Exception' and 'Control.Exception' module Control.Eff.ExceptionExtra ( liftTry , maybeThrow @@ -16,7 +16,6 @@ import qualified Control.Monad.Catch as Catch import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Eff.Exception as Eff import GHC.Stack import Control.Eff.Reader.Lazy as Lazy 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,11 +1,212 @@ --- | A logging effect based on 'Control.Monad.Log.MonadLog'. +-- | A logging effect. +-- +-- There is just one log message type: 'LogMessage' and it is written using 'logMsg' and +-- the functions built on top of it. +-- +-- The 'Logs' effect is tightly coupled with the 'LogWriterReader' effect. +-- When using the 'Control.Monad.Trans.ControlMonadBaseControl' instance, the underlying monad of the 'LogWriter', +-- that is expected to be present through the respective 'LogWriterReader', is +-- constrained to be the base monad itself, e.g. 'IO'. +-- +-- The log message type is fixed to 'LogMessage', and there is a type class for +-- converting to that, call 'ToLogMessage'. +-- +-- There is a single global 'LogPredicate' that can be used to suppress logs directly +-- at the point where they are sent, in the 'logMsg' function. +-- +-- Note that all logging is eventually done via 'logMsg'; 'logMsg' is the __only__ place where +-- log filtering should happen. +-- +-- Also, 'LogMessage's are evaluated using 'Control.DeepSeq.deepseq', __after__ they pass the 'LogPredicate', also inside 'logMsg'. +-- +-- Example: +-- +-- > exampleLogging :: IO () +-- > exampleLogging = +-- > runLift +-- > $ withLogging consoleLogWriter +-- > $ 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" +-- +-- == Asynchronous Logging +-- +-- Logging in a 'Control.Concurrent.Async.withAsync' spawned thread is done using 'withAsyncLogging'. +-- +-- == 'LogPredicate's +-- +-- See "Control.Eff.Log.Handler#LogPredicate" module Control.Eff.Log - ( module Control.Eff.Log.Handler - , module Control.Eff.Log.Channel + ( -- * 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 + -- | The module that contains the 'LogMessage' and 'LogPredicate' definitions. + -- + -- The log message type corresponds 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 + -- | 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.Handler import Control.Eff.Log.Channel +import Control.Eff.Log.Handler import Control.Eff.Log.Message +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 testPred (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" + testPred = 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 --- a/src/Control/Eff/Log/Channel.hs +++ b/src/Control/Eff/Log/Channel.hs @@ -1,101 +1,88 @@ --- | Concurrent Logging +-- | Asynchronous Logging module Control.Eff.Log.Channel - ( LogChannel() - , withAsyncLogChannel - , handleLoggingAndIO - , handleLoggingAndIO_ - ) -where + ( withAsyncLogging + ) where -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Eff as Eff -import Control.Eff.Lift -import Control.Exception ( evaluate ) -import Control.Monad ( void - , unless - ) -import Control.Eff.Log.Handler -import Data.Foldable ( traverse_ ) -import Data.Kind ( ) -import Control.DeepSeq -import GHC.Stack +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 in a 'LogChannel', which is passed to the second function. --- If the function returns or throws, the logging process will be killed. +-- 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 usage, a super stupid log to file: +-- Example: -- --- > --- > main = --- > withAsyncLogChannel --- > 1000 --- > (singleMessageLogWriter putStrLn) --- > (handleLoggingAndIO --- > (do logMsg "test 1" --- > logMsg "test 2" --- > logMsg "test 3")) +-- > exampleAsyncLogging :: IO () +-- > exampleAsyncLogging = +-- > runLift +-- > $ withSomeLogging @IO +-- > $ withAsyncLogging (1000::Int) consoleLogWriter +-- > $ do logMsg "test 1" +-- > logMsg "test 2" +-- > logMsg "test 3" -- > -- -withAsyncLogChannel - :: forall message a len - . (NFData message, Integral len) +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 message IO -- ^ An IO action to write the log messages - -> (LogChannel message -> IO a) + -> 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) - writeAllLogMessages ioWriter ms - logLoop tq - --- | Fork an IO based log writer thread and set the 'LogWriter' to an action --- that will send all logs to that thread via a bounded queue. --- When the queue is full, flush it -handleLoggingAndIO - :: (NFData m, HasCallStack) - => Eff '[Logs m, LogWriterReader m IO, Lift IO] a - -> LogChannel m - -> IO a -handleLoggingAndIO e lc = runLift - (writeLogs (foldingLogWriter (traverse_ logChannelPutIO)) e) - where - logQ = fromLogChannel lc - logChannelPutIO (force -> me) = do - !m <- evaluate me - atomically - (do - dropMessage <- isFullTBQueue logQ - unless dropMessage (writeTBQueue logQ m) - ) + where + logLoop tq = do + ms <- + atomically $ do + h <- readTBQueue tq + t <- flushTBQueue tq + return (h : t) + traverse_ ioWriter ms + logLoop tq --- | Like 'handleLoggingAndIO' but return @()@. -handleLoggingAndIO_ - :: (NFData m, HasCallStack) - => Eff '[Logs m, LogWriterReader m IO, Lift IO] a - -> LogChannel m - -> IO () -handleLoggingAndIO_ e lc = void (handleLoggingAndIO e lc) +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 --- | 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 = - ConcurrentLogChannel - { fromLogChannel :: TBQueue message - , _logChannelThread :: Async () - } - -- ^ send all log messages to a log process +data LogChannel = ConcurrentLogChannel + { fromLogChannel :: TBQueue LogMessage + , _logChannelThread :: Async () + } 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 @@ -1,430 +1,732 @@ --- | A logging effect based on 'Control.Monad.Log.MonadLog'. +{-# LANGUAGE UndecidableInstances #-} +-- | A memory efficient, streaming, logging effect with support for +-- efficiently not logging when no logs are required. +-- +-- Good support for logging to a file or to the network, +-- as well as asynchronous logging in another thread. module Control.Eff.Log.Handler - ( logMsg - , logMsgs - , HasLogWriter - , mapLogMessages - , filterLogMessages - , traverseLogMessages - , changeLogWriter - , ignoreLogs - , traceLogs - , LogWriter() + ( -- * Logging API + -- ** Sending Log Messages + logMsg + , logWithSeverity + , logEmergency + , logAlert + , logCritical + , logError + , logWarning + , logNotice + , logInfo + , logDebug + + -- ** Log Message Pre-Filtering #LogPredicate# + -- $LogPredicate + , includeLogMessages + , excludeLogMessages + , setLogPredicate + , modifyLogPredicate + , askLogPredicate + + -- * Log Handling API + + -- ** Writing Logs , LogWriterReader - , foldingLogWriter - , writeAllLogMessages - , singleMessageLogWriter - , multiMessageLogWriter + , setLogWriter + , addLogWriter + -- *** Log Message Modification + , withLogFileAppender + , censorLogs + , censorLogsM , askLogWriter + , modifyLogWriter + + -- ** 'Logs' Effect Handling , Logs() - , writeLogs + , LogsTo + , withConsoleLogging + , withIoLogging + , withLogging + , withSomeLogging + , LoggingAndIo + -- ** Low-Level API for Custom Extensions + -- *** Log Message Interception , runLogs + , respondToLogMessage + , interceptLogMessages + -- *** LogWriter Handling + , runLogWriterReader + ) where import Control.DeepSeq import Control.Eff as Eff import Control.Eff.Extend -import Control.Eff.Reader.Strict -import Control.Eff.Lift as Eff +import Control.Eff.Log.Message +import Control.Eff.Log.Writer import qualified Control.Exception.Safe as Safe -import Data.Foldable ( traverse_ ) -import Data.Default -import Control.Monad +import Control.Lens +import Control.Monad ( when, (>=>) ) +import Control.Monad.Base ( MonadBase() ) import qualified Control.Monad.Catch as Catch -import Control.Monad.Trans.Control ( MonadBaseControl - ( restoreM - , liftBaseWith - , StM - ) +import Control.Monad.Trans.Control ( MonadBaseControl + ( restoreM + , liftBaseWith + , StM + ) + , liftBaseOp + ) +import Data.Default +import Data.Function ( fix ) +import GHC.Stack ( HasCallStack + , callStack + , withFrozenCallStack ) -import Control.Monad.Base ( MonadBase() ) -import Debug.Trace +import qualified System.IO as IO +import System.Directory ( canonicalizePath + , createDirectoryIfMissing + ) +import System.FilePath ( takeDirectory ) --- * Message Logging Effect --- | Log a message. The message is reduced to normal form (strict). -logMsg :: (NFData m, Member (Logs m) e) => m -> Eff e () -logMsg (force -> msg) = logMsgs [msg] +-- | This effect sends 'LogMessage's and is a reader for a 'LogPredicate'. +-- +-- Logs are sent via 'logMsg'; +-- for more informaion about log predicates, see "Control.Eff.Log.Handler#LogPredicate" +-- +-- This effect is handled via 'withLogging'. +data Logs v where + AskLogFilter + :: Logs LogPredicate + WriteLogMessage + :: !LogMessage -> Logs () --- | Log a bunch of messages. This might be more efficient than calling 'logMsg' --- multiple times. --- The messages are reduced to normal form (strict). -logMsgs - :: ( Traversable f - , MonadPlus f - , NFData1 f - , NFData (f m) - , NFData m - , Member (Logs m) e - ) - => f m - -> Eff e () -logMsgs !msgs = rnf1 msgs `seq` do - f <- send AskLogFilter - send - (LogMsgs - (do - m <- msgs - maybe mzero (return . force) (f m) +instance forall e a k. Handle Logs e a (LogPredicate -> k) where + handle h q AskLogFilter p = h (q ^$ p ) p + handle h q (WriteLogMessage _) p = h (q ^$ ()) p + +-- | This instance allows lifting to the 'Logs' effect, they do, however, need a +-- 'LogWriter' in the base monad, in order to be able to handle 'logMsg' invocations. +-- +-- The 'LogWriterReader' effect is must be available to get to the 'LogWriter'. +-- +-- Otherwise there is no way to preserve to log messages. +instance forall m e. (MonadBase m m, LiftedBase m e, SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e)) + => MonadBaseControl m (Eff (Logs ': e)) where + type StM (Eff (Logs ': e)) a = StM (Eff e) a + liftBaseWith f = do + lf <- askLogPredicate + raise (liftBaseWith (\runInBase -> f (runInBase . runLogs @m lf))) + restoreM = raise . restoreM + +instance (LiftedBase m e, Catch.MonadThrow (Eff e)) + => Catch.MonadThrow (Eff (Logs ': e)) where + throwM exception = raise (Catch.throwM exception) + +instance (Applicative m, LiftedBase m e, Catch.MonadCatch (Eff e), SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e)) + => Catch.MonadCatch (Eff (Logs ': e)) where + catch effect handler = do + lf <- askLogPredicate + let lower = runLogs @m lf + nestedEffects = lower effect + nestedHandler exception = lower (handler exception) + raise (Catch.catch nestedEffects nestedHandler) + +instance (Applicative m, LiftedBase m e, Catch.MonadMask (Eff e), SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e)) + => Catch.MonadMask (Eff (Logs ': e)) where + mask maskedEffect = do + lf <- askLogPredicate + let + lower :: Eff (Logs ': e) a -> Eff e a + lower = runLogs @m lf + raise + (Catch.mask + (\nestedUnmask -> lower + (maskedEffect + ( raise . nestedUnmask . lower ) + ) + ) + ) + uninterruptibleMask maskedEffect = do + lf <- askLogPredicate + let + lower :: Eff (Logs ': e) a -> Eff e a + lower = runLogs @m lf + raise + (Catch.uninterruptibleMask + (\nestedUnmask -> lower + (maskedEffect + ( raise . nestedUnmask . lower ) + ) + ) + ) + generalBracket acquire release useIt = do + lf <- askLogPredicate + let + lower :: Eff (Logs ': e) a -> Eff e a + lower = runLogs @m lf + raise + (Catch.generalBracket + (lower acquire) + (((.).(.)) lower release) + (lower . useIt) ) - ) --- ** Filter and Transform Log Messages --- | Map a pure function over log messages. -mapLogMessages - :: forall m r b - . (NFData m, Member (Logs m) r) - => (m -> m) - -> Eff r b - -> Eff r b -mapLogMessages f eff = do - old <- send AskLogFilter - interpose return (go (fmap f . old)) eff - where - go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b - go t AskLogFilter k = k t - go _ (LogMsgs ms) k = logMsgs ms >>= k +-- | A constraint alias for effects that requires a 'LogWriterReader', as well as that the +-- contained 'LogWriterReader' has a 'SupportsLogger' instance. +-- +-- The requirements of this constraint are provided by: +-- * 'withStdOutLogging' +-- * 'withIoLogging' +-- * 'withLogging' +-- * 'withSomeLogging' +-- +type LogsTo h e = (Member Logs e, SupportsLogger h e, SetMember LogWriterReader (LogWriterReader h) e) --- | Keep only those messages, for which a predicate holds. +-- | Enable logging to @stdout@ using the 'defaultIoLogWriter' in combination with +-- the 'consoleLogWriter'. -- --- E.g. to keep only messages which begin with @"OMG"@: +-- Example: -- --- > filterLogMessages (\msg -> case msg of --- > 'O':'M':'G':_ -> True --- > _ -> False) --- > (do logMsg "this message will not be logged" --- > logMsg "OMG logged") -filterLogMessages - :: forall m r b - . (NFData m, Member (Logs m) r) - => (m -> Bool) - -> Eff r b - -> Eff r b -filterLogMessages predicate eff = do - old <- send AskLogFilter - interpose return (go (\m -> if predicate m then old m else Nothing)) eff - where - go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b - go t AskLogFilter k = k t - go _ (LogMsgs ms) k = logMsgs ms >>= k +-- > 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 + -> Facility + -> LogPredicate + -> Eff (Logs : LogWriterReader IO : e) a + -> Eff e a +withConsoleLogging = withIoLogging consoleLogWriter --- interpose return go --- where --- go :: Logs m a -> Arr r a b -> Eff r b - -- go (LogMsgs ms) k = logMsgs (mfilter predicate ms) >>= k +-- | 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 + -> String + -> Facility + -> LogPredicate + -> Eff (Logs : LogWriterReader IO : e) a + -> Eff e a +withIoLogging lw appName facility defaultPredicate = + withLogging (defaultIoLogWriter appName facility lw) + . setLogPredicate defaultPredicate --- ** Filter and Transform Log Messages effectfully +-- | Handle the 'Logs' and 'LogWriterReader' effects. +-- +-- It installs the given 'LogWriter', which determines the underlying +-- 'LogWriter' type parameter. +-- +-- Example: +-- +-- > exampleWithLogging :: IO () +-- > exampleWithLogging = +-- > runLift +-- > $ withLogging consoleLogWriter +-- > $ logDebug "Oh, hi there" +-- +withLogging :: + forall h e a. (Applicative h, LogsTo h (Logs ': LogWriterReader h ': e)) + => LogWriter h -> Eff (Logs ': LogWriterReader h ': e) a -> Eff e a +withLogging lw = runLogWriterReader lw . runLogs allLogMessages --- | Map an 'Eff'ectful function over every bunch of log messages. +-- | Handles the 'Logs' and 'LogWriterReader' effects. -- --- For example, to attach the current time to each log message: +-- By default it uses the 'noOpLogWriter', but using 'setLogWriter' the +-- 'LogWriter' can be replaced. -- --- > appendTimestamp --- > :: ( Member (Logs String) e --- > , Lifted IO e) --- > => Eff e a --- > -> Eff e a --- > appendTimestamp = traverseLogMessages $ \ms -> do --- > now <- getCurrentTime --- > return (fmap (show now ++) ms) -traverseLogMessages - :: forall m r h b - . ( Member (Logs m) r - , Monad h - , Lifted h r - , Member (Reader (LogWriter m h)) r - ) - => (forall f . (MonadPlus f, Traversable f, NFData1 f) => f m -> h (f m)) - -> Eff r b - -> Eff r b -traverseLogMessages f = changeLogWriter - (\msgs -> do - lw <- ask - msgs' <- lift (f msgs) - lift (runLogWriter lw msgs') - ) +-- This is like 'withLogging' applied to 'noOpLogWriter' +-- +-- Example: +-- +-- > exampleWithSomeLogging :: () +-- > exampleWithSomeLogging = +-- > run +-- > $ withSomeLogging @PureLogWriter +-- > $ logDebug "Oh, hi there" +-- +withSomeLogging :: + forall h e a. + (Applicative h, LogsTo h (Logs ': LogWriterReader h ': e)) + => Eff (Logs ': LogWriterReader h ': e) a + -> Eff e a +withSomeLogging = withLogging (noOpLogWriter @h) --- ** Change the Log Writer +-- | The concrete list of 'Eff'ects for logging with an IO based 'LogWriter', and a 'LogWriterReader'. +type LoggingAndIo = '[Logs, LogWriterReader IO, Lift IO] --- | Change the way log messages are *written*. --- Replaces the existing 'LogWriter' by a new one. The new 'LogWriter' --- is constructed from a function that gets a /bunch/ of messages and --- returns an 'Eff'ect. --- That effect has a 'Reader' for the previous 'LogWriter' and 'Lift's --- the log writer base monad. -changeLogWriter - :: forall r m h a - . (Monad h, Lifted h r, Member (Reader (LogWriter m h)) r) - => ( forall f - . (Traversable f, NFData1 f, MonadPlus f) - => f m - -> Eff '[Reader (LogWriter m h), Lift h] () - ) - -> Eff r a - -> Eff r a -changeLogWriter interceptor = - let replaceWriter old = LogWriter (runLift . runReader old . interceptor) - in local replaceWriter +-- | Raw handling of the 'Logs' effect. +-- Exposed for custom extensions, if in doubt use 'withLogging'. +runLogs + :: forall h e b . + (LogsTo h (Logs ': e), SupportsLogger h (Logs ': e)) + => LogPredicate + -> Eff (Logs ': e) b + -> Eff e b +runLogs p m = + fix (handle_relay (\a _ -> return a)) (sendLogMessageToLogWriter m) p --- * Handle Log Messages +-- | Log a message. +-- +-- All logging goes through this function. +-- +-- 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 + lf <- askLogPredicate + when (lf msgIn) $ + msgIn `deepseq` send @Logs (WriteLogMessage msgIn) --- | Throw away all log messages. -ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a -ignoreLogs = handle_relay return go - where - go :: Logs message v -> Arr r v a -> Eff r a - go (LogMsgs _) k = k () - go AskLogFilter k = k (const Nothing) +-- | Log a 'String' as 'LogMessage' with a given 'Severity'. +logWithSeverity + :: forall e . + ( HasCallStack + , Member Logs e + ) + => Severity + -> String + -> Eff e () +logWithSeverity !s = + withFrozenCallStack + $ logMsg + . setCallStack callStack + . set lmSeverity s + . flip (set lmMessage) def --- | Trace all log messages using 'traceM'. The message value is --- converted to 'String' using the given function. -traceLogs - :: forall message r a - . (message -> String) - -> Eff (Logs message ': r) a - -> Eff r a -traceLogs toString = handle_relay return go - where - go :: Logs message v -> Arr r v a -> Eff r a - go (LogMsgs ms) k = traverse_ (traceM . toString) ms >> k () - go AskLogFilter k = k pure +-- | Log a 'String' as 'emergencySeverity'. +logEmergency + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity) --- ** Log Message Writer Creation +-- | Log a message with 'alertSeverity'. +logAlert + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logAlert = withFrozenCallStack (logWithSeverity alertSeverity) --- | A function that takes a log message and returns an effect that --- /logs/ the message. -newtype LogWriter message writerM = - LogWriter - { runLogWriter - :: forall f. (MonadPlus f, Traversable f, NFData1 f) - => f message - -> writerM () - } +-- | Log a 'criticalSeverity' message. +logCritical + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logCritical = withFrozenCallStack (logWithSeverity criticalSeverity) -instance Applicative w => Default (LogWriter m w) where - def = LogWriter (const (pure ())) +-- | Log a 'errorSeverity' message. +logError + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logError = withFrozenCallStack (logWithSeverity errorSeverity) --- | Type alias for the 'Reader' effect that writes logs -type LogWriterReader message writerM = - Reader (LogWriter message writerM) +-- | Log a 'warningSeverity' message. +logWarning + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logWarning = withFrozenCallStack (logWithSeverity warningSeverity) --- | Create a 'LogWriter' from a function that can write --- a 'Traversable' container. -foldingLogWriter - :: ( forall f - . (MonadPlus f, Traversable f, NFData1 f) - => f message - -> writerM () +-- | Log a 'noticeSeverity' message. +logNotice + :: forall e . + ( HasCallStack + , Member Logs e ) - -> LogWriter message writerM -foldingLogWriter = LogWriter + => String + -> Eff e () +logNotice = withFrozenCallStack (logWithSeverity noticeSeverity) --- | Efficiently apply the 'LogWriter' to a 'Traversable' container of log --- messages. -writeAllLogMessages - :: (NFData1 f, MonadPlus f, Traversable f, Applicative writerM) - => LogWriter message writerM - -> f message - -> writerM () -writeAllLogMessages = runLogWriter +-- | Log a 'informationalSeverity' message. +logInfo + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logInfo = withFrozenCallStack (logWithSeverity informationalSeverity) --- | Create a 'LogWriter' from a function that is applied to each --- individual log message. NOTE: This is probably the simplest, --- but also the most inefficient and annoying way to make --- a 'LogWriter'. Better use 'foldingLogWriter' or even --- 'multiMessageLogWriter'. -singleMessageLogWriter - :: (Applicative writerM) - => (message -> writerM ()) - -> LogWriter message writerM -singleMessageLogWriter writeMessage = foldingLogWriter (traverse_ writeMessage) +-- | Log a 'debugSeverity' message. +logDebug + :: forall e . + ( HasCallStack + , Member Logs e + ) + => String + -> Eff e () +logDebug = withFrozenCallStack (logWithSeverity debugSeverity) --- | Create a 'LogWriter' from a function that is applied to each --- individual log message. Don't be scared by the type signature, --- here is an example file appender that re-opens the log file --- everytime a bunch of log messages are written: +-- $LogPredicate -- --- > fileAppender fn = multiMessageLogWriter --- > (\writeLogMessageWith -> --- > withFile fn AppendMode (writeLogMessageWith . hPutStrLn)) +-- Ways to change the 'LogPredicate' are: -- -multiMessageLogWriter - :: (Applicative writerM) - => (((message -> writerM ()) -> writerM ()) -> writerM ()) - -> LogWriter message writerM -multiMessageLogWriter withMessageWriter = - foldingLogWriter (\xs -> withMessageWriter (\writer -> traverse_ writer xs)) - --- | Get the current 'LogWriter' -askLogWriter - :: forall m h r . (Member (Reader (LogWriter m h)) r) => Eff r (LogWriter m h) -askLogWriter = ask - --- ** Low-Level Log Message Sending +-- * 'setLogPredicate'. +-- * 'modifyLogPredicate'. +-- * 'includeLogMessages' +-- * 'excludeLogMessages' +-- +-- The current predicate is retrieved via 'askLogPredicate'. +-- +-- Some pre-defined 'LogPredicate's can be found here: "Control.Eff.Log.Message#PredefinedPredicates" --- | A constraint that combines constraints for logging into any --- log writer monad. -type HasLogWriter message logWriterMonad effects = - ( Member (Reader (LogWriter message logWriterMonad)) effects - , Member (Logs message) effects - , NFData message - , Monad logWriterMonad - , Lifted logWriterMonad effects - ) +-- | Get the current 'Logs' filter/transformer function. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +askLogPredicate :: forall e . (Member Logs e) => Eff e LogPredicate +askLogPredicate = send @Logs AskLogFilter --- | This effect sends log messages. --- The logs are not sent one-by-one, but always in batches of --- containers that must be 'Traversable' and 'MonadPlus' instances. --- Log messages are consumed by 'LogWriter's installed via --- 'runLogs' or more high level functions like 'writeLogs'. -data Logs m v where - AskLogFilter - :: (NFData m) => Logs m (m -> Maybe m) - LogMsgs - :: (Traversable f, MonadPlus f, NFData1 f, NFData m, NFData (f m)) - => f m -> Logs m () +-- | Keep only those messages, for which a predicate holds. +-- +-- E.g. to keep only messages which begin with @"OMG"@: +-- +-- > exampleLogPredicate :: IO Int +-- > exampleLogPredicate = +-- > runLift +-- > $ withLogging consoleLogWriter +-- > $ do logMsg "test" +-- > setLogPredicate (\ msg -> case view lmMessage msg of +-- > 'O':'M':'G':_ -> True +-- > _ -> False) +-- > (do logMsg "this message will not be logged" +-- > logMsg "OMG logged" +-- > return 42) +-- +-- In order to also delegate to the previous predicate, use 'modifyLogPredicate' +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +setLogPredicate + :: forall r b + . (Member Logs r, HasCallStack) + => LogPredicate + -> Eff r b + -> Eff r b +setLogPredicate = modifyLogPredicate . const --- | Install 'Logs' handler that 'ask's for a 'LogWriter' for the --- message type and applies the log writer to the messages. -runLogsFiltered - :: forall m h e b - . (NFData m, Applicative h, Lifted h e, Member (LogWriterReader m h) e) - => (m -> Maybe m) - -> Eff (Logs m ': e) b +-- | Change the 'LogPredicate'. +-- +-- Other than 'setLogPredicate' this function allows to include the previous predicate, too. +-- +-- For to discard all messages currently no satisfying the predicate and also all messages +-- that are to long: +-- +-- @ +-- modifyLogPredicate (\previousPredicate msg -> previousPredicate msg && length (lmMessage msg) < 29 ) +-- (do logMsg "this message will not be logged" +-- logMsg "this message might be logged") +-- @ +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +modifyLogPredicate + :: forall e b + . (Member Logs e, HasCallStack) + => (LogPredicate -> LogPredicate) -> Eff e b -runLogsFiltered f = handle_relay return (go f) - where - go :: (m -> Maybe m) -> Logs m a -> Arr e a c -> Eff e c - go lt AskLogFilter k = k lt - go _lt (LogMsgs ms) k = do - logWrtr <- ask - lift (writeAllLogMessages logWrtr (force ms)) - k () - --- | Install 'Logs' handler that 'ask's for a 'LogWriter' for the --- message type and applies the log writer to the messages. -runLogs - :: forall m h e b - . (Applicative h, Lifted h e, Member (LogWriterReader m h) e, NFData m) - => Eff (Logs m ': e) b -> Eff e b -runLogs = runLogsFiltered pure +modifyLogPredicate lpIn e = askLogPredicate >>= fix step e . lpIn + where + ret x _ = return x + step :: (Eff e b -> LogPredicate -> Eff e b) -> Eff e b -> LogPredicate -> Eff e b + step k (E q (prj -> Just (WriteLogMessage !l))) lp = do + logMsg l + respond_relay @Logs ret k (q ^$ ()) lp + step k m lp = respond_relay @Logs ret k m lp --- | Handle log message effects by a monadic action, e.g. an IO action --- to send logs to the console output or a log-server. --- The monadic log writer action is wrapped in a newtype called --- 'LogWriter'. +-- | Include 'LogMessage's that match a 'LogPredicate'. -- --- Use the smart constructors below to create them, e.g. --- 'foldingLogWriter', 'singleMessageLogWriter' or --- 'mulitMessageLogWriter'. -writeLogs - :: forall message writerM r a - . (Applicative writerM, Lifted writerM r, NFData message) - => LogWriter message writerM - -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a - -> Eff r a -writeLogs w = runReader w . runLogs +-- @excludeLogMessages p@ allows log message to be logged if @p m@ +-- +-- Although it is enough if the previous predicate holds. +-- See 'excludeLogMessages' and 'modifyLogPredicate'. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +includeLogMessages + :: forall e a . (Member Logs e) + => LogPredicate -> Eff e a -> Eff e a +includeLogMessages p = modifyLogPredicate (\p' m -> p' m || p m) --- | Handle log message effects by a monadic action, e.g. an IO action --- to send logs to the console output or a log-server. --- The monadic log writer action is wrapped in a newtype called --- 'LogWriter'. +-- | Exclude 'LogMessage's that match a 'LogPredicate'. -- --- Use the smart constructors below to create them, e.g. --- 'foldingLogWriter', 'singleMessageLogWriter' or --- 'mulitMessageLogWriter'. -writeLogsFiltered - :: forall message writerM r a - . (Applicative writerM, Lifted writerM r, NFData message) - => (message -> Maybe message) - -> LogWriter message writerM - -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a - -> Eff r a -writeLogsFiltered f w = runReader w . runLogsFiltered f +-- @excludeLogMessages p@ discards logs if @p m@ +-- +-- Also the previous predicate must also hold for a +-- message to be logged. +-- See 'excludeLogMessages' and 'modifyLogPredicate'. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +excludeLogMessages + :: forall e a . (Member Logs e) + => LogPredicate -> Eff e a -> Eff e a +excludeLogMessages p = modifyLogPredicate (\p' m -> not (p m) && p' m) --- | This instance allows liftings of the 'Logs' effect, but only, if there is --- a 'LogWriter' in effect. -instance - ( MonadBase m m - , Lifted m r - , NFData l - , MonadBaseControl m (Eff r) - ) - => MonadBaseControl m (Eff (Logs l ': LogWriterReader l m ': r)) where +-- | Consume log messages. +-- +-- Exposed for custom extensions, if in doubt use 'withLogging'. +-- +-- Respond to all 'LogMessage's logged from the given action, +-- up to any 'MonadBaseControl' liftings. +-- +-- Note that all logging is done through 'logMsg' and that means +-- only messages passing the 'LogPredicate' are received. +-- +-- The 'LogMessage's are __consumed__ once they are passed to the +-- given callback function, previous 'respondToLogMessage' invocations +-- further up in the call stack will not get the messages anymore. +-- +-- Use 'interceptLogMessages' if the messages shall be passed +-- any previous handler. +-- +-- NOTE: The effects of this function are __lost__ when using +-- 'MonadBaseControl', 'Catch.MonadMask', 'Catch.MonadCatch' and 'Catch.MonadThrow'. +-- +-- In contrast the functions based on modifying the 'LogWriter', +-- such as 'addLogWriter' or 'censorLogs', are save to use in combination +-- with the aforementioned liftings. +respondToLogMessage + :: forall r b + . (Member Logs r) + => (LogMessage -> Eff r ()) + -> Eff r b + -> Eff r b +respondToLogMessage f e = askLogPredicate >>= fix step e + where + step :: (Eff r b -> LogPredicate -> Eff r b) -> Eff r b -> LogPredicate -> Eff r b + step k (E q (prj -> Just (WriteLogMessage !l))) lp = do + f l + respond_relay @Logs ret k (q ^$ ()) lp + step k m lp = respond_relay @Logs ret k m lp + ret x _lf = return x - type StM (Eff (Logs l ': LogWriterReader l m ': r)) a = - StM (Eff r) a +-- | Change the 'LogMessage's using an effectful function. +-- +-- Exposed for custom extensions, if in doubt use 'withLogging'. +-- +-- This differs from 'respondToLogMessage' in that the intercepted messages will be +-- written either way, albeit in altered form. +-- +-- NOTE: The effects of this function are __lost__ when using +-- 'MonadBaseControl', 'Catch.MonadMask', 'Catch.MonadCatch' and 'Catch.MonadThrow'. +-- +-- In contrast the functions based on modifying the 'LogWriter', +-- such as 'addLogWriter' or 'censorLogs', are save to use in combination +-- with the aforementioned liftings. +interceptLogMessages + :: forall r b + . (Member Logs r) + => (LogMessage -> Eff r LogMessage) + -> Eff r b + -> Eff r b +interceptLogMessages f = respondToLogMessage (f >=> logMsg) - liftBaseWith f = do - l <- askLogWriter - lf <- send AskLogFilter - raise (raise (liftBaseWith (\runInBase -> f (runInBase . writeLogsFiltered lf l)))) +-- | Internal function. +sendLogMessageToLogWriter + :: forall h e b . + (LogsTo h e, SupportsLogger h e, Member Logs e) + => Eff e b -> Eff e b +sendLogMessageToLogWriter = respondToLogMessage messageCallback + where + messageCallback msg = do + lw <- askLogWriter + liftLogWriter lw msg - restoreM = raise . raise . restoreM +-- | A Reader specialized for 'LogWriter's +-- +-- The existing @Reader@ couldn't be used together with 'SetMember', so this +-- lazy reader was written, specialized to reading 'LogWriter'. +data LogWriterReader h v where + AskLogWriter :: LogWriterReader h (LogWriter h) +instance Handle (LogWriterReader h) e a (LogWriter h -> k) where + handle k q AskLogWriter lw = k (q ^$ lw) lw -instance (NFData l, Lifted m e, Catch.MonadThrow (Eff e)) - => Catch.MonadThrow (Eff (Logs l ': LogWriterReader l m ': e)) where - throwM exception = raise (raise (Catch.throwM exception)) +instance forall h m r. (MonadBase m m, LiftedBase m r) + => MonadBaseControl m (Eff (LogWriterReader h ': r)) where + type StM (Eff (LogWriterReader h ': r)) a = StM (Eff r) a + liftBaseWith f = do + lf <- askLogWriter + raise (liftBaseWith (\runInBase -> f (runInBase . runLogWriterReader lf))) + restoreM = raise . restoreM -instance (NFData l, Applicative m, Lifted m e, Catch.MonadCatch (Eff e)) - => Catch.MonadCatch (Eff (Logs l ': LogWriterReader l m ': e)) where +instance (LiftedBase m e, Catch.MonadThrow (Eff e)) + => Catch.MonadThrow (Eff (LogWriterReader h ': e)) where + throwM exception = raise (Catch.throwM exception) + +instance (Applicative m, LiftedBase m e, Catch.MonadCatch (Eff e)) + => Catch.MonadCatch (Eff (LogWriterReader h ': e)) where catch effect handler = do - logWriter <- ask @(LogWriter l m) - logFilter <- send AskLogFilter - let lower = writeLogsFiltered logFilter logWriter + lf <- askLogWriter + let lower = runLogWriterReader lf nestedEffects = lower effect nestedHandler exception = lower (handler exception) - raise (raise (Catch.catch nestedEffects nestedHandler)) + raise (Catch.catch nestedEffects nestedHandler) -instance (NFData l, Applicative m, Lifted m e, Catch.MonadMask (Eff e)) - => Catch.MonadMask (Eff (Logs l ': LogWriterReader l m ': e)) where +instance (Applicative m, LiftedBase m e, Catch.MonadMask (Eff e)) + => Catch.MonadMask (Eff (LogWriterReader h ': e)) where mask maskedEffect = do - logWriter <- ask @(LogWriter l m) - logFilter <- send AskLogFilter + lf <- askLogWriter let - lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a - lower = writeLogsFiltered logFilter logWriter + lower :: Eff (LogWriterReader h ': e) a -> Eff e a + lower = runLogWriterReader lf raise - (raise (Catch.mask (\nestedUnmask -> lower (maskedEffect - ( raise . raise . nestedUnmask . lower ) + ( raise . nestedUnmask . lower ) ) ) ) - ) uninterruptibleMask maskedEffect = do - logWriter <- ask @(LogWriter l m) - logFilter <- send AskLogFilter + lf <- askLogWriter let - lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a - lower = writeLogsFiltered logFilter logWriter + lower :: Eff (LogWriterReader h ': e) a -> Eff e a + lower = runLogWriterReader lf raise - (raise (Catch.uninterruptibleMask (\nestedUnmask -> lower (maskedEffect - ( raise . raise . nestedUnmask . lower ) + ( raise . nestedUnmask . lower ) ) ) ) - ) - generalBracket acquire release use = do - logWriter <- ask @(LogWriter l m) - logFilter <- send AskLogFilter + generalBracket acquire release useIt = do + lf <- askLogWriter let - lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a - lower = writeLogsFiltered logFilter logWriter + lower :: Eff (LogWriterReader h ': e) a -> Eff e a + lower = runLogWriterReader lf raise - (raise (Catch.generalBracket (lower acquire) (((.).(.)) lower release) - (lower . use) - ) + (lower . useIt) ) + +-- | Provide the 'LogWriter' +-- +-- Exposed for custom extensions, if in doubt use 'withLogging'. +runLogWriterReader :: LogWriter h -> Eff (LogWriterReader h ': e) a -> Eff e a +runLogWriterReader e m = fix (handle_relay (\x _ -> return x)) m e + +-- | Get the current 'LogWriter'. +askLogWriter :: SetMember LogWriterReader (LogWriterReader h) e => Eff e (LogWriter h) +askLogWriter = send AskLogWriter + +-- | Change the current 'LogWriter'. +modifyLogWriter + :: forall h e a. LogsTo h e => (LogWriter h -> LogWriter h) -> Eff e a -> Eff e a +modifyLogWriter f = localLogWriterReader . sendLogMessageToLogWriter + where + localLogWriterReader m = + f <$> askLogWriter >>= fix (respond_relay @(LogWriterReader h) (\x _ -> return x)) m + + +-- | Replace the current 'LogWriter'. +-- To add an additional log message consumer use 'addLogWriter' +setLogWriter :: forall h e a. LogsTo h e => LogWriter h -> Eff e a -> Eff e a +setLogWriter = modifyLogWriter . const + +-- | Modify the the 'LogMessage's written in the given sub-expression. +-- +-- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriter'@ +censorLogs :: LogsTo h e => (LogMessage -> LogMessage) -> Eff e a -> Eff e a +censorLogs = modifyLogWriter . mappingLogWriter + +-- | Modify the the 'LogMessage's written in the given sub-expression, as in 'censorLogs' +-- but with a effectful function. +-- +-- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriterM'@ +censorLogsM + :: (LogsTo h e, Monad h) + => (LogMessage -> h LogMessage) -> Eff e a -> Eff e a +censorLogsM = modifyLogWriter . mappingLogWriterM + +-- | Combine the effects of a given 'LogWriter' and the existing one. +-- +-- > +-- > exampleAddLogWriter :: IO () +-- > exampleAddLogWriter = go >>= putStrLn +-- > where go = fmap (unlines . map renderLogMessage . snd) +-- > $ runLift +-- > $ runCapturedLogsWriter +-- > $ withLogging listLogWriter +-- > $ addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter) +-- > $ addLogWriter (filteringLogWriter testPred (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" +-- > testPred = view (lmSeverity . to (<= errorSeverity)) +-- > +-- +addLogWriter :: forall h e a . + (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,31 +1,65 @@ -- | An RFC 5434 inspired log message and convenience functions for -- logging them. module Control.Eff.Log.Message - ( LogMessage(..) - , HasLogging + ( -- * Log Message Data Type + LogMessage(..) + -- ** Field Accessors + , lmFacility + , lmSeverity + , lmTimestamp + , lmHostname + , lmAppName + , lmProcessId + , lmMessageId + , lmStructuredData + , lmSrcLoc + , lmThreadId + , lmMessage + + -- *** IO Based 'LogMessage' Modification + , setCallStack + , prefixLogMessagesWith + , setLogMessageTimestamp + , setLogMessageThreadId + , setLogMessageHostname + + -- ** Log Message Text Rendering , renderRFC5424 , printLogMessage - , ioLogMessageHandler - , ioLogMessageWriter - , traceLogMessageWriter , renderLogMessage - , increaseLogMessageDistance - , dropDistantLogMessages - , logWithSeverity - , logEmergency - , logAlert - , logCritical - , logError - , logWarning - , logNotice - , logInfo - , logDebug + + -- ** Log Message Construction , errorMessage , infoMessage , debugMessage + + -- *** Type Class for Conversion to 'LogMessage' + , ToLogMessage(..) + + -- *** IO Based Constructor , errorMessageIO , infoMessageIO , debugMessageIO + + -- * 'LogMessage' Predicates #PredefinedPredicates# + -- $PredefinedPredicates + , LogPredicate + , allLogMessages + , noLogMessages + , lmSeverityIs + , lmSeverityIsAtLeast + , lmMessageStartsWith + , discriminateByAppName + + -- ** RFC-5424 Structured Data + , StructuredDataElement(..) + , SdParameter(..) + , sdName + , sdParamValue + , sdElementId + , sdElementParameters + + -- * RFC 5424 Severity , Severity(fromSeverity) , emergencySeverity , alertSeverity @@ -35,7 +69,10 @@ , noticeSeverity , informationalSeverity , debugSeverity + + -- * RFC 5424 Facility , Facility(fromFacility) + -- ** Facility Constructors , kernelMessages , userLevelMessages , mailSystem @@ -59,152 +96,70 @@ , local5 , local6 , local7 - , lmFacility - , lmSeverity - , lmTimestamp - , lmHostname - , lmAppname - , lmProcessId - , lmMessageId - , lmStructuredData - , lmSrcLoc - , lmThreadId - , lmMessage - , lmDistance - , setCallStack - , setLogMessageTimestamp - , setLogMessageThreadId - , StructuredDataElement(..) - , sdElementId - , sdElementParameters ) where import Control.Concurrent import Control.DeepSeq -import Control.Eff -import Control.Eff.Lift -import Control.Eff.Log.Handler import Control.Lens import Control.Monad ( (>=>) ) import Control.Monad.IO.Class import Data.Default -import Data.Foldable import Data.Maybe import Data.String import Data.Time.Clock import Data.Time.Format -import Debug.Trace -import GHC.Generics +import GHC.Generics hiding (to) import GHC.Stack +import Network.HostName as Network import System.FilePath.Posix import Text.Printf -- | 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 - , _lmDistance :: Int } + 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} deriving (Eq, Generic) --- | A convenient alias for the constraints that enable logging of 'LogMessage's --- in the monad, which is 'Lift'ed into a given @Eff@ effect list. -type HasLogging writerM effect = (HasLogWriter LogMessage writerM effect) - -showLmMessage :: LogMessage -> [String] -showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg _dist) = - 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 - --- | A 'LogWriter' that applys 'renderLogMessage' to the log message and then --- traces it using 'traceM'. -traceLogMessageWriter :: Monad m => LogWriter LogMessage m -traceLogMessageWriter = - foldingLogWriter (traverse_ (traceM . renderLogMessage)) - - --- | 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 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 :: String - , _sdElementParameters :: [SdParameter]} + 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) ++ "]" + show (SdElement sdId params) = + "[" ++ sdName sdId ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]" instance NFData StructuredDataElement --- | Component of a 'StructuredDataElement' +-- | Component of an RFC-5424 'StructuredDataElement' data SdParameter = - SdParameter String String + MkSdParameter !String !String deriving (Eq, Ord, Generic) instance Show SdParameter where - show (SdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\"" + 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 '"' -> "\\\"" @@ -228,304 +183,466 @@ 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 = LogMessage def def def def def def def def def def "" 0 - -instance IsString LogMessage where - fromString = infoMessage - --- | Render a 'LogMessage' but set the timestamp and thread id fields. -printLogMessage :: LogMessage -> IO () -printLogMessage = setLogMessageTimestamp >=> putStrLn . renderLogMessage - --- | Set a timestamp (if not set), the thread id (if not set) using IO actions --- then /write/ the log message using the 'IO' and 'String' based 'LogWriter'. -ioLogMessageWriter - :: HasCallStack => LogWriter String IO -> LogWriter LogMessage IO -ioLogMessageWriter delegatee = foldingLogWriter - ( traverse setLogMessageTimestamp - >=> traverse setLogMessageThreadId - >=> (writeAllLogMessages delegatee . fmap renderLogMessage) - ) - --- | Use 'ioLogMessageWriter' to /handle/ logging using 'handleLogs'. -ioLogMessageHandler - :: (HasCallStack, Lifted IO e) - => LogWriter String IO - -> Eff (Logs LogMessage ': LogWriterReader LogMessage IO ': e) a - -> Eff e a -ioLogMessageHandler delegatee = - writeLogs (ioLogMessageWriter delegatee) - --- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps') --- in 'lmTimestamp'. -setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage -setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp) - then do - now <- liftIO getCurrentTime - return (m & lmTimestamp ?~ now) - else return m - --- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId') --- to 'lmMessage'. -setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage -setLogMessageThreadId m = if isNothing (m ^. lmThreadId) - then do - t <- liftIO myThreadId - return (m & lmThreadId ?~ t) - else return m - --- | Increase the /distance/ of log messages by one. --- Logs can be filtered by their distance with 'dropDistantLogMessages' -increaseLogMessageDistance - :: (HasCallStack, HasLogWriter LogMessage h e) => Eff e a -> Eff e a -increaseLogMessageDistance = mapLogMessages (over lmDistance (+ 1)) - --- | Drop all log messages with an 'lmDistance' greater than the given --- value. -dropDistantLogMessages :: (HasLogging m r) => Int -> Eff r a -> Eff r a -dropDistantLogMessages maxDistance = - filterLogMessages (\lm -> lm ^. lmDistance <= maxDistance) - --- | Log a 'String' as 'LogMessage' with a given 'Severity'. -logWithSeverity - :: ( HasCallStack - , 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 - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity) - --- | Log a message with 'alertSeverity'. -logAlert - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logAlert = withFrozenCallStack (logWithSeverity alertSeverity) - --- | Log a 'criticalSeverity' message. -logCritical - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logCritical = withFrozenCallStack (logWithSeverity criticalSeverity) - --- | Log a 'errorSeverity' message. -logError - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logError = withFrozenCallStack (logWithSeverity errorSeverity) - --- | Log a 'warningSeverity' message. -logWarning - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logWarning = withFrozenCallStack (logWithSeverity warningSeverity) - --- | Log a 'noticeSeverity' message. -logNotice - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logNotice = withFrozenCallStack (logWithSeverity noticeSeverity) - --- | Log a 'informationalSeverity' message. -logInfo - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logInfo = withFrozenCallStack (logWithSeverity informationalSeverity) - --- | Log a 'debugSeverity' message. -logDebug - :: ( HasCallStack - , Member (Logs LogMessage) e - ) - => String - -> Eff e () -logDebug = withFrozenCallStack (logWithSeverity debugSeverity) - --- | Construct a 'LogMessage' with 'errorSeverity' -errorMessage :: HasCallStack => String -> LogMessage -errorMessage m = withFrozenCallStack - (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack) - --- | Construct a 'LogMessage' with 'informationalSeverity' -infoMessage :: HasCallStack => String -> LogMessage -infoMessage m = withFrozenCallStack - ( def - & lmSeverity - .~ informationalSeverity - & lmMessage - .~ m - & setCallStack callStack - ) - --- | Construct a 'LogMessage' with 'debugSeverity' -debugMessage :: HasCallStack => String -> LogMessage -debugMessage m = withFrozenCallStack - (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack) - --- | Construct a 'LogMessage' with 'errorSeverity' -errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage -errorMessageIO = - withFrozenCallStack - $ (setLogMessageThreadId >=> setLogMessageTimestamp) - . errorMessage - --- | Construct a 'LogMessage' with 'informationalSeverity' -infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage -infoMessageIO = - withFrozenCallStack - $ (setLogMessageThreadId >=> setLogMessageTimestamp) - . infoMessage - --- | Construct a 'LogMessage' with 'debugSeverity' -debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage -debugMessageIO = - withFrozenCallStack - $ (setLogMessageThreadId >=> setLogMessageTimestamp) - . debugMessage +-- *** 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 => + (String -> f String) + -> 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 String -> f (Maybe String)) -> 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 + +-- | A lens for the user defined textual message of a 'LogMessage' +lmMessage :: Functor f => + (String -> f String) -> 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 + +-- | 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 is 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 + +-- | 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 + +-- | Prefix the 'lmMessage'. +prefixLogMessagesWith :: String -> LogMessage -> LogMessage +prefixLogMessagesWith = over lmMessage . (<>) + +-- | An IO action that sets the current UTC time in 'lmTimestamp'. +setLogMessageTimestamp :: LogMessage -> IO LogMessage +setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp) + then do + now <- getCurrentTime + return (m & lmTimestamp ?~ now) + else return m + +-- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId') +-- to 'lmMessage'. +setLogMessageThreadId :: LogMessage -> IO LogMessage +setLogMessageThreadId m = if isNothing (m ^. lmThreadId) + then do + t <- myThreadId + return (m & lmThreadId ?~ t) + else return m + +-- | An IO action that sets the current hosts fully qualified hostname in 'lmHostname'. +setLogMessageHostname :: LogMessage -> IO LogMessage +setLogMessageHostname m = if isNothing (m ^. lmTimestamp) + then do + fqdn <- Network.getHostName + return (m & lmHostname ?~ fqdn) + else return m + +-- | Construct a 'LogMessage' with 'errorSeverity' +errorMessage :: HasCallStack => String -> LogMessage +errorMessage m = withFrozenCallStack + (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack) + +-- | Construct a 'LogMessage' with 'informationalSeverity' +infoMessage :: HasCallStack => String -> LogMessage +infoMessage m = withFrozenCallStack + ( def + & lmSeverity + .~ informationalSeverity + & lmMessage + .~ m + & setCallStack callStack + ) + +-- | Construct a 'LogMessage' with 'debugSeverity' +debugMessage :: HasCallStack => String -> LogMessage +debugMessage m = withFrozenCallStack + (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack) + +-- | Construct a 'LogMessage' with 'errorSeverity' +errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage +errorMessageIO = + withFrozenCallStack + $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp) + . errorMessage + +-- | Construct a 'LogMessage' with 'informationalSeverity' +infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage +infoMessageIO = + withFrozenCallStack + $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp) + . infoMessage + +-- | Construct a 'LogMessage' with 'debugSeverity' +debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage +debugMessageIO = + withFrozenCallStack + $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp) + . debugMessage + +-- | Things that can become a 'LogMessage' +class ToLogMessage a where + -- | Convert the value to a 'LogMessage' + toLogMessage :: a -> LogMessage + +instance ToLogMessage LogMessage where + toLogMessage = id + +instance ToLogMessage String where + toLogMessage = infoMessage + +instance IsString LogMessage where + fromString = infoMessage + +-- $PredefinedPredicates +-- == Log Message Predicates +-- +-- These are the predefined 'LogPredicate's: +-- +-- * 'allLogMessages' +-- * 'noLogMessages' +-- * 'lmSeverityIsAtLeast' +-- * 'lmSeverityIs' +-- * 'lmMessageStartsWith' +-- * 'discriminateByAppName' +-- +-- To find out how to use these predicates, +-- goto "Control.Eff.Log.Handler#LogPredicate" + + +-- | The filter predicate for message that shall be logged. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +type LogPredicate = LogMessage -> Bool + +-- | All messages. +allLogMessages :: LogPredicate +allLogMessages = const True + +-- | No messages. +noLogMessages :: LogPredicate +noLogMessages = const False + +-- | Match 'LogMessage's that have exactly the given severity. +-- See 'lmSeverityIsAtLeast'. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +lmSeverityIs :: Severity -> LogPredicate +lmSeverityIs s = view (lmSeverity . to (== s)) + +-- | Match 'LogMessage's that have the given severity __or worse__. +-- See 'lmSeverityIs'. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +lmSeverityIsAtLeast :: Severity -> LogPredicate +lmSeverityIsAtLeast s = view (lmSeverity . to (<= s)) + +-- | Match 'LogMessage's whose 'lmMessage' starts with the given string. +-- +-- See "Control.Eff.Log.Handler#LogPredicate" +lmMessageStartsWith :: String -> LogPredicate +lmMessageStartsWith prefix lm = + case length prefix of + 0 -> True + prefixLen -> take prefixLen (lm ^. lmMessage) == prefix + +-- | Apply discriminate 'LogMessage's by their 'lmAppName' and delegate +-- to one of two 'LogPredicate's. +-- +-- One useful application for this is to allow info and debug message +-- from one application, e.g. the current application itself, +-- while at the same time allowing only warning and error messages +-- from third party libraries. +discriminateByAppName :: String -> LogPredicate -> LogPredicate -> LogPredicate +discriminateByAppName appName appPredicate otherPredicate lm = + if view lmAppName lm == Just appName + then appPredicate lm + else otherPredicate lm diff --git a/src/Control/Eff/Log/Writer.hs b/src/Control/Eff/Log/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Writer.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE UndecidableInstances #-} +-- | The 'LogWriter' type encapsulates an effectful function to write 'LogMessage's. +-- +-- Used in conjunction with the 'SupportsLogger' class, it +-- can be used to write messages from within an effectful +-- computation. +module Control.Eff.Log.Writer + ( -- * 'LogWriter' Definition + LogWriter(MkLogWriter, runLogWriter) + , SupportsLogger(..) + -- ** 'LogWriter' Zoo + -- *** Pure Writer + , noOpLogWriter + , debugTraceLogWriter + , PureLogWriter(..) + , listLogWriter + , CaptureLogs(..) + , CapturedLogsWriter + , runCapturedLogsWriter + -- ** IO Based 'LogWriter' + , consoleLogWriter + , ioHandleLogWriter + -- *** General Combinator + , filteringLogWriter + , mappingLogWriter + , mappingLogWriterM + -- *** IO Based Combinator + , ioLogWriter + , defaultIoLogWriter + ) where + +import Control.Eff +import Control.Eff.Log.Message +import Data.Default +import Debug.Trace +import GHC.Stack +import Control.Eff.Writer.Strict (Writer, tell, runListWriter) +import Data.Functor.Identity (Identity) +import Control.DeepSeq (deepseq) +import Data.Foldable (traverse_) +import System.IO +import Control.Monad ((>=>)) +import Control.Lens + +-- | A function that takes a log message and returns an effect that +-- /logs/ the message. +newtype LogWriter writerM = MkLogWriter + { runLogWriter :: LogMessage -> writerM () + } + +instance Applicative w => Default (LogWriter w) where + def = MkLogWriter (const (pure ())) + +-- * LogWriter liftings + +-- | This class describes how to lift the log writer action into some monad. +-- +-- The second parameter is almost always @Eff x@ +-- so usually the method of this class lifts the log writer action into an effect monad. +class SupportsLogger h e where + liftLogWriter :: LogWriter h -> LogMessage -> Eff e () + +-- * 'LogWriter' Zoo + +-- ** Pure Log Writers + +-- | A base monad for all side effect free 'LogWriter'. +-- +-- This is only required e.g. when logs are only either discarded or traced. +-- See 'debugTraceLogWriter' or 'noOpLogWriter'. +-- +-- This is just a wrapper around 'Identity' and serves as a type that has a special +-- 'SupportsLogger' instance. +newtype PureLogWriter a = MkPureLogWriter { runPureLogWriter :: Identity a } + deriving (Functor, Applicative, Monad) + +-- | A 'LogWriter' monad for 'Debug.Trace' based pure logging. +instance SupportsLogger PureLogWriter e where + liftLogWriter lw msg = deepseq (runPureLogWriter (runLogWriter lw msg)) (return ()) + +-- | This 'LogWriter' will discard all messages. +-- +-- 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 'SupportsLogger' instance for this type assumes a 'Writer' effect. +instance Member CapturedLogsWriter e => SupportsLogger CaptureLogs e where + liftLogWriter lw = traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs . runLogWriter lw + +-- | 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 uses an 'IO' action to write the message. +ioHandleLogWriter :: HasCallStack => Handle -> LogWriter IO +ioHandleLogWriter h = ioLogWriter (hPutStrLn h . renderLogMessage) + +instance (Lifted IO e) => SupportsLogger IO e where + liftLogWriter = (lift . ) . runLogWriter + +-- | Write 'LogMessage's to standard output, formatted with 'printLogMessage'. +consoleLogWriter :: LogWriter IO +consoleLogWriter = ioLogWriter printLogMessage + +-- | Decorate an IO based 'LogWriter' to set important fields in log messages. +-- +-- ALl log messages are censored to include basic log message information: +-- +-- * 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 installs the given 'LogWriter', wrapped using 'mappingLogWriterM'. +defaultIoLogWriter :: String -> Facility -> LogWriter IO -> 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. +filteringLogWriter :: Monad e => LogPredicate -> LogWriter e -> LogWriter e +filteringLogWriter p lw = MkLogWriter (\msg -> if p msg then (runLogWriter lw msg) else return ()) + +-- | A 'LogWriter' that applies a function to the 'LogMessage' and delegates the result to +-- to the given writer. +mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter e -> LogWriter e +mappingLogWriter f lw = MkLogWriter (runLogWriter lw . f) + +-- | Like 'mappingLogWriter' allow the function that changes the 'LogMessage' to have effects. +mappingLogWriterM :: Monad e => (LogMessage -> e LogMessage) -> LogWriter e -> LogWriter e +mappingLogWriterM f lw = MkLogWriter (f >=> runLogWriter lw) diff --git a/stack.nightly-2018-05-29.yaml b/stack.nightly-2018-05-29.yaml deleted file mode 100644 --- a/stack.nightly-2018-05-29.yaml +++ /dev/null @@ -1,68 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: nightly-2018-05-29 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: -- brittany-0.10.0.0 -- extensible-effects-3.0.0.0 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-12.19 +resolver: lts-13.13 # User packages to be built. # Various formats can be used as shown in the example below. @@ -40,7 +40,7 @@ # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) extra-deps: - - extensible-effects-3.1.0.2 + - extensible-effects-5.0.0.1 # Override default flag values for local packages and extra-deps # flags: {} # Extra package databases containing global packages diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,76 +1,50 @@ module Common where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Eff.Concurrent.Process -import Control.Eff -import Control.Eff.Extend -import Control.Eff.Log -import Control.Eff.Lift -import Control.Lens -import Control.Monad ( void - , when - ) -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Runners -import GHC.Stack +import Control.Concurrent +import Control.Concurrent.STM +import Control.Eff +import Control.Eff.Concurrent.Process +import Control.Eff.Extend +import Control.Eff.Log +import Control.Monad (void) +import GHC.Stack +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Runners setTravisTestOptions :: TestTree -> TestTree -setTravisTestOptions = - localOption (timeoutSeconds 60) . localOption (NumThreads 1) +setTravisTestOptions = localOption (timeoutSeconds 60) . localOption (NumThreads 1) timeoutSeconds :: Integer -> Timeout timeoutSeconds seconds = Timeout (seconds * 1000000) (show seconds ++ "s") -withTestLogC - :: (e -> LogChannel LogMessage -> IO ()) - -> (IO (e -> IO ()) -> TestTree) - -> TestTree -withTestLogC doSchedule k = k - (return - (\e -> withAsyncLogChannel - (1000 :: Integer) - (multiMessageLogWriter - (\writeWith -> - writeWith - (\m -> when (view lmSeverity m < errorSeverity) $ printLogMessage m) - ) - ) - (doSchedule e) - ) - ) +withTestLogC :: (e -> IO ()) -> (IO (e -> IO ()) -> TestTree) -> TestTree +withTestLogC doSchedule k = k (return doSchedule) untilInterrupted :: Member t r => t (ResumeProcess v) -> Eff r () untilInterrupted pa = do r <- send pa case r of Interrupted _ -> return () - _ -> untilInterrupted pa + _ -> untilInterrupted pa -scheduleAndAssert - :: forall r - . (SetMember Lift (Lift IO) r, Member (Logs LogMessage) r) +scheduleAndAssert :: + forall r. (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) - -> ( (String -> Bool -> Eff (InterruptableProcess r) ()) - -> Eff (InterruptableProcess r) () - ) + -> ((String -> Bool -> Eff (InterruptableProcess r) ()) -> Eff (InterruptableProcess r) ()) -> IO () -scheduleAndAssert schedulerFactory testCaseAction = withFrozenCallStack $ do - resultVar <- newEmptyTMVarIO - void - (applySchedulerFactory - schedulerFactory - (testCaseAction - (\title cond -> lift (atomically (putTMVar resultVar (title, cond)))) - ) - ) - (title, result) <- atomically (takeTMVar resultVar) - assertBool title result +scheduleAndAssert schedulerFactory testCaseAction = + withFrozenCallStack $ do + resultVar <- newEmptyTMVarIO + void + (applySchedulerFactory + schedulerFactory + (testCaseAction (\title cond -> lift (atomically (putTMVar resultVar (title, cond)))))) + (title, result) <- atomically (takeTMVar resultVar) + assertBool title result -applySchedulerFactory - :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) +applySchedulerFactory :: + forall r. (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> Eff (InterruptableProcess r) () -> IO () diff --git a/test/ForkIOScheduler.hs b/test/ForkIOScheduler.hs --- a/test/ForkIOScheduler.hs +++ b/test/ForkIOScheduler.hs @@ -5,8 +5,6 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Eff.Extend -import Control.Eff.Lift -import Control.Eff.Log import Control.Eff.Loop import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer @@ -19,8 +17,6 @@ import Test.Tasty.HUnit import Data.Dynamic import Common -import Numeric.Natural -import Data.Default test_IOExceptionsIsolated :: TestTree test_IOExceptionsIsolated = setTravisTestOptions $ testGroup @@ -33,10 +29,7 @@ ) $ do aVar <- newEmptyTMVarIO - withAsyncLogChannel - (1000 :: Natural) - def -- (singleMessageLogWriter (putStrLn . renderLogMessage)) - (Scheduler.defaultMainWithLogChannel + (Scheduler.defaultMain (do p1 <- spawn $ foreverCheap busyEffect lift (threadDelay 1000) @@ -94,29 +87,21 @@ test_mainProcessSpawnsAChildAndReturns = setTravisTestOptions (testCase "spawn a child and return" - (withAsyncLogChannel - (1000 :: Natural) - def - (Scheduler.defaultMainWithLogChannel + (Scheduler.defaultMain (void (spawn (void receiveAnyMessage))) ) - ) ) test_mainProcessSpawnsAChildAndExitsNormally :: TestTree test_mainProcessSpawnsAChildAndExitsNormally = setTravisTestOptions (testCase "spawn a child and exit normally" - (withAsyncLogChannel - (1000 :: Natural) - def - (Scheduler.defaultMainWithLogChannel + (Scheduler.defaultMain (do void (spawn (void receiveAnyMessage)) void exitNormally fail "This should not happen!!" ) - ) ) ) @@ -126,10 +111,7 @@ setTravisTestOptions (testCase "spawn a child with a busy send loop and exit normally" - (withAsyncLogChannel - (1000 :: Natural) - def - (Scheduler.defaultMainWithLogChannel + (Scheduler.defaultMain (do void (spawn (foreverCheap (void (sendMessage 1000 "test")))) void exitNormally @@ -137,55 +119,44 @@ ) ) ) - ) test_mainProcessSpawnsAChildBothReturn :: TestTree test_mainProcessSpawnsAChildBothReturn = setTravisTestOptions (testCase "spawn a child and let it return and return" - (withAsyncLogChannel - (1000 :: Natural) - def - (Scheduler.defaultMainWithLogChannel + (Scheduler.defaultMain (do child <- spawn (void (receiveMessage @String)) sendMessage child "test" return () ) - ) - ) - ) + )) test_mainProcessSpawnsAChildBothExitNormally :: TestTree test_mainProcessSpawnsAChildBothExitNormally = setTravisTestOptions (testCase "spawn a child and let it exit and exit" - (withAsyncLogChannel - (1000 :: Natural) - def - (Scheduler.defaultMainWithLogChannel - (do - child <- spawn $ void $ provideInterrupts $ exitOnInterrupt - (do - void (receiveMessage @String) + (Scheduler.defaultMain + (do + child <- spawn $ void $ provideInterrupts $ exitOnInterrupt + (do + void (receiveMessage @String) + void exitNormally + error "This should not happen (child)!!" + ) + sendMessage child "test" void exitNormally - error "This should not happen (child)!!" + error "This should not happen!!" ) - sendMessage child "test" - void exitNormally - error "This should not happen!!" - ) ) ) - ) test_timer :: TestTree test_timer = setTravisTestOptions $ testCase "flush via timer" - $ withAsyncLogChannel (1000 :: Natural) def - $ Scheduler.defaultMainWithLogChannel + $ Scheduler.defaultMain $ do let n = 100 testMsg :: Float diff --git a/test/Interactive.hs b/test/Interactive.hs --- a/test/Interactive.hs +++ b/test/Interactive.hs @@ -2,7 +2,6 @@ import Control.Concurrent import Control.Eff -import Control.Eff.Lift import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Interactive import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs --- a/test/LoggingTests.hs +++ b/test/LoggingTests.hs @@ -1,40 +1,45 @@ module LoggingTests where import Control.Eff -import Control.Eff.Lift import Control.Eff.Log import Test.Tasty import Test.Tasty.HUnit import Common -import Control.Concurrent.STM -import Control.DeepSeq +import Control.Lens ((.~)) -demo :: ([Logs String, Logs OtherLogMsg] <:: e) => Eff e () -demo = do - logMsg "jo" - logMsg (OtherLogMsg "test 123") +test_Logging :: TestTree +test_Logging = setTravisTestOptions $ testGroup "Logging" + [ basics + , strictness + ] -test_loggingInterception :: TestTree -test_loggingInterception = setTravisTestOptions $ testGroup - "Intercept Logging" - [ testCase "Convert Log Message Type" $ do - otherLogsQueue <- newTQueueIO @OtherLogMsg - stringLogsQueue <- newTQueueIO @String - runLift - (writeLogs - (multiMessageLogWriter ($ (atomically . writeTQueue stringLogsQueue))) - (writeLogs - (multiMessageLogWriter ($ (atomically . writeTQueue otherLogsQueue)) - ) - (mapLogMessages @String reverse demo) - ) - ) - otherLogs <- atomically (flushTQueue otherLogsQueue) - strLogs <- atomically (flushTQueue stringLogsQueue) - assertEqual "string logs" ["oj"] strLogs - assertEqual "other logs" [OtherLogMsg "test 123"] otherLogs - ] +basics :: HasCallStack => TestTree +basics = + testCase "basic logging works" $ + pureLogs demo @?= (lmSrcLoc .~ Nothing) <$> [infoMessage "jo", debugMessage "oh"] + where -newtype OtherLogMsg = OtherLogMsg String deriving (Eq, NFData, Show) + demo :: ('[Logs] <:: e) => Eff e () + demo = do + logInfo "jo" + logDebug "oh" + + pureLogs :: Eff '[Logs, LogWriterReader CaptureLogs, CapturedLogsWriter] a -> [LogMessage] + pureLogs = + snd + . run + . runCapturedLogsWriter + . withLogging listLogWriter + . censorLogs @CaptureLogs (lmSrcLoc .~ Nothing) + +strictness :: HasCallStack => TestTree +strictness = + testCase "messages failing the predicate are not deeply evaluated" + $ runLift + $ withLogging consoleLogWriter + $ excludeLogMessages (lmSeverityIs errorSeverity) + $ do logDebug "test" + logMsg (errorMessage ("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 @@ -25,10 +25,7 @@ "scheduleMonadIOEff with many yields from replicateCheapM_" $ do res <- - Scheduler.scheduleIOWithLogging - (multiMessageLogWriter - ($! (putStrLn . (">>> " ++))) - ) + Scheduler.scheduleIOWithLogging consoleLogWriter $ replicateCheapM_ soMany yieldProcess res @=? Right () , testCase @@ -46,12 +43,7 @@ , testCase "'foreverCheap' inside a child process and 'replicateCheapM_' in the main process" $ do - res <- - Scheduler.scheduleIOWithLogging - (multiMessageLogWriter - ($! (putStrLn . (">>> " ++))) - ) - + res <- Scheduler.scheduleIOWithLogging (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage)) $ do me <- self spawn_ (foreverCheap $ sendMessage me ()) @@ -72,10 +64,7 @@ [ testCase "scheduleMonadIOEff with many yields from replicateM_" $ do res <- - Scheduler.scheduleIOWithLogging - (multiMessageLogWriter - ($! (putStrLn . (">>> " ++))) - ) + Scheduler.scheduleIOWithLogging (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage)) $ replicateM_ soMany yieldProcess res @=? Right () , testCase @@ -95,10 +84,7 @@ "'forever' inside a child process and 'replicateM_' in the main process" $ do res <- - Scheduler.scheduleIOWithLogging - (multiMessageLogWriter - ($! (putStrLn . (">>> " ++))) - ) + Scheduler.scheduleIOWithLogging (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage)) $ 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 @@ -20,38 +20,44 @@ import Control.Eff.Extend import Control.Eff.Log import Control.Eff.Loop -import Control.Eff.Lift import Control.Monad import Test.Tasty import Test.Tasty.HUnit import Common import Control.Applicative import Data.Void +import Control.Lens (view) testInterruptReason :: InterruptReason testInterruptReason = ProcessError "test interrupt" test_forkIo :: TestTree test_forkIo = setTravisTestOptions $ withTestLogC - (\c lc -> handleLoggingAndIO_ (ForkIO.schedule c) lc) + (\c -> + runLift + $ withSomeLogging @IO + $ withAsyncLogging (100 :: Int) (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m))) + $ ForkIO.schedule c) (\factory -> testGroup "ForkIOScheduler" [allTests factory]) test_singleThreaded :: TestTree test_singleThreaded = setTravisTestOptions $ withTestLogC - (\e logC -> - -- void (runLift (logToChannel logC (SingleThreaded.schedule (return ()) e))) + (\e -> let runEff - :: Eff '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO] a + :: Eff LoggingAndIo a -> IO a - runEff = flip handleLoggingAndIO logC + runEff = + runLift + . withLogging + (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m))) in void $ SingleThreaded.scheduleM runEff yield e ) (\factory -> testGroup "SingleThreadedScheduler" [allTests factory]) allTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree allTests schedulerFactory = localOption @@ -102,23 +108,25 @@ stopReturnToSender toP = call toP StopReturnToSender returnToSenderServer - :: forall q . ( HasCallStack, Member (Logs LogMessage) q ) + :: forall q + . (HasCallStack, Member Logs q) => Eff (InterruptableProcess q) (Server ReturnToSender) returnToSenderServer = spawnApiServer - (handleCalls (\m k -> k $ - case m of - StopReturnToSender -> do - return (Nothing, StopServer testInterruptReason) - ReturnToSender fromP echoMsg -> do - sendMessage fromP echoMsg - yieldProcess - return (Just True, AwaitNext) - ) - ) stopServerOnInterrupt + (handleCalls + (\m k -> k $ case m of + StopReturnToSender -> do + return (Nothing, StopServer testInterruptReason) + ReturnToSender fromP echoMsg -> do + sendMessage fromP echoMsg + yieldProcess + return (Just True, AwaitNext) + ) + ) + stopServerOnInterrupt selectiveReceiveTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree selectiveReceiveTests schedulerFactory = setTravisTestOptions @@ -137,8 +145,8 @@ void $ receiveSelectedMessage (filterMessage (== n)) go (n - 1) - senderLoop receviverPid = - traverse_ (sendMessage receviverPid) [1 .. nMax] + senderLoop destination = + traverse_ (sendMessage destination) [1 .. nMax] me <- self receiverPid <- spawn (receiverLoop me) @@ -163,15 +171,15 @@ () <- receiveMessage () <- receiveMessage -- replicateCheapM_ 40 yieldProcess - msgs <- flushMessages - lift (length msgs @?= 30) + messages <- flushMessages + lift (length messages @?= 30) ] ) yieldLoopTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree yieldLoopTests schedulerFactory = @@ -211,7 +219,7 @@ pingPongTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree pingPongTests schedulerFactory = testGroup @@ -286,7 +294,7 @@ errorTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree errorTests schedulerFactory = testGroup @@ -331,7 +339,7 @@ concurrencyTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree concurrencyTests schedulerFactory = @@ -442,7 +450,7 @@ exitTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree exitTests schedulerFactory = @@ -591,7 +599,7 @@ sendShutdownTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree sendShutdownTests schedulerFactory = testGroup @@ -684,7 +692,7 @@ linkingTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree linkingTests schedulerFactory = setTravisTestOptions @@ -851,7 +859,7 @@ monitoringTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree monitoringTests schedulerFactory = setTravisTestOptions @@ -921,7 +929,7 @@ timerTests :: forall r - . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r) + . (Lifted IO r, LogsTo IO r) => IO (Eff (InterruptableProcess r) () -> IO ()) -> TestTree timerTests schedulerFactory = setTravisTestOptions diff --git a/with-hoogle.nix b/with-hoogle.nix new file mode 100644 --- /dev/null +++ b/with-hoogle.nix @@ -0,0 +1,22 @@ +# Use `ghc.WithHoogle` as `ghc` in `haskellPackages` +{ + +# Library of functions to use, for composeExtensions. +lib ? (import {}).pkgs.lib + +# Input set of all haskell packages. A valid input would be: +# (import {}).pkgs.haskellPackages +haskellPackages ? (import {}).pkgs.haskellPackages + +}: + +haskellPackages.override + (old: { + overrides = + lib.composeExtensions + (old.overrides or (_: _: {})) + (self: super: { + ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; + ghcWithPackages = self.ghc.withPackages; + }); + })