extensible-effects-concurrent 0.4.0.0 → 0.5.0.0
raw patch · 14 files changed
+623/−179 lines, 14 filesdep +data-default
Dependencies added: data-default
Files
- .travis.yml +31/−0
- ChangeLog.md +7/−0
- brittany.yaml +55/−0
- extensible-effects-concurrent.cabal +13/−5
- src/Control/Eff/Concurrent/Api/Server.hs +3/−3
- src/Control/Eff/Concurrent/Examples2.hs +95/−90
- src/Control/Eff/Concurrent/Process.hs +1/−2
- src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +17/−20
- src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +36/−22
- src/Control/Eff/Log.hs +22/−33
- src/Control/Eff/Log/MessageFactory.hs +56/−0
- src/Control/Eff/Log/Syslog.hs +249/−0
- stack.yaml +3/−4
- test/LoggingTests.hs +35/−0
+ .travis.yml view
@@ -0,0 +1,31 @@+language: c++sudo: false++addons:+ apt:+ sources:+ - hvr-ghc+ packages:+ - ghc-8.2.2++before_install:+ - mkdir -p ~/.local/bin+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+ - export PATH=~/.local/bin:/opt/ghc/$GHCVER/bin:$PATH+ - chmod a+x ~/.local/bin/stack++install:+ - stack --no-terminal --skip-ghc-check setup++script:+ - stack --no-terminal --skip-ghc-check build+ - stack --no-terminal --skip-ghc-check build --test --test-arguments '-p "$0 !~ /Loops WITH space leaks/ " --num-threads=2 +RTS -qa -qm -N2 -maxN2 -RTS'+ - stack --no-terminal --skip-ghc-check haddock++cache:+ directories:+ - ~/.stack+ - ~/.local+ - ~/.stack-work-cache+ apt: true
ChangeLog.md view
@@ -1,5 +1,12 @@ # Changelog for extensible-effects-concurrent +## 0.5.0.0++- Switch to `extensible-effects` version `3.1.0.0`+- Bump to stackage LTS-12.9+- Add `Control.Eff.Log.MessageFactory`+- Add `Control.Eff.Log.Syslog`+ ## 0.4.0.0 - Switch to `extensible-effects` version `3.0.0.0`
+ brittany.yaml view
@@ -0,0 +1,55 @@+conf_debug:+ dconf_roundtrip_exactprint_only: false+ dconf_dump_bridoc_simpl_par: false+ dconf_dump_ast_unknown: false+ dconf_dump_bridoc_simpl_floating: false+ dconf_dump_config: false+ dconf_dump_bridoc_raw: false+ dconf_dump_bridoc_final: false+ dconf_dump_bridoc_simpl_alt: false+ dconf_dump_bridoc_simpl_indent: false+ dconf_dump_annotations: false+ dconf_dump_bridoc_simpl_columns: false+ dconf_dump_ast_full: false+conf_forward:+ options_ghc:+ - -XLambdaCase+ - -XMultiWayIf+ - -XGADTs+ - -XViewPatterns+ - -XTupleSections+ - -XExplicitForAll+ - -XQuasiQuotes+ - -XTemplateHaskell+ - -XBangPatterns+ - -XTypeInType+ - -XTypeApplications+ - -XTypeFamilies+conf_errorHandling:+ econf_ExactPrintFallback: ExactPrintFallbackModeInline+ econf_Werror: false+ econf_omit_output_valid_check: false+ econf_produceOutputOnErrors: false+conf_preprocessor:+ ppconf_CPPMode: CPPModeAbort+ ppconf_hackAroundIncludes: false+conf_version: 1+conf_layout:+ lconfig_reformatModulePreamble: true+ lconfig_altChooser:+ tag: AltChooserBoundedSearch+ contents: 3+ lconfig_allowSingleLineExportList: false+ lconfig_importColumn: 50+ lconfig_hangingTypeSignature: false+ lconfig_importAsColumn: 50+ lconfig_alignmentLimit: 30+ lconfig_indentListSpecial: true+ lconfig_indentAmount: 2+ lconfig_alignmentBreakOnMultiline: true+ lconfig_cols: 80+ lconfig_indentPolicy: IndentPolicyFree+ lconfig_indentWhereSpecial: true+ lconfig_columnAlignMode:+ tag: ColumnAlignModeMajority+ contents: 0.7
extensible-effects-concurrent.cabal view
@@ -1,5 +1,5 @@ name: extensible-effects-concurrent-version: 0.4.0.0+version: 0.5.0.0 description: Please see the README on GitHub at <https://github.com/sheyll/extensible-effects-concurrent#readme> synopsis: Message passing concurrency as extensible-effect homepage: https://github.com/sheyll/extensible-effects-concurrent#readme@@ -21,6 +21,8 @@ stack.nightly-2018-05-29.yaml ChangeLog.md README.md+ brittany.yaml+ .travis.yml source-repository head type: git@@ -31,6 +33,7 @@ src build-depends: base >=4.9 && <5,+ data-default, deepseq, directory, filepath,@@ -52,6 +55,8 @@ Control.Eff.Loop, Control.Eff.ExceptionExtra, Control.Eff.Log,+ Control.Eff.Log.Syslog,+ Control.Eff.Log.MessageFactory, Control.Eff.Concurrent, Control.Eff.Concurrent.Api, Control.Eff.Concurrent.Api.Client,@@ -78,6 +83,7 @@ FlexibleInstances, GADTs, GeneralizedNewtypeDeriving,+ LambdaCase, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,@@ -98,14 +104,15 @@ main-is: Driver.hs hs-source-dirs: test other-modules:- Paths_extensible_effects_concurrent+ Common+ , Debug , ForkIOScheduler , Interactive- , SingleThreadedScheduler+ , LoggingTests , LoopTests+ , Paths_extensible_effects_concurrent , ProcessBehaviourTestCases- , Debug- , Common+ , SingleThreadedScheduler ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N build-depends: base >=4.9 && <5@@ -125,6 +132,7 @@ , DataKinds , FlexibleContexts , GADTs+ , GeneralizedNewtypeDeriving , RankNTypes , ScopedTypeVariables , TemplateHaskell
src/Control/Eff/Concurrent/Api/Server.hs view
@@ -40,7 +40,7 @@ => SchedulerProxy q -> ApiHandler p r -> Eff r ()-serve px handlers = receiveLoop px $ \mReq -> case mReq of+serve px handlers = receiveLoop px $ \case Left Nothing -> applyApiHandler px handlers (Terminate Nothing) Left (Just reason) -> applyApiHandler px handlers (Terminate (Just reason)) Right dyn -> ensureAllHandled@@ -135,7 +135,7 @@ => SchedulerProxy q -> Maybe String -> Eff r ()-defaultTermination px e = maybe (exitNormally px) (exitWithError px) e+defaultTermination px = maybe (exitNormally px) (exitWithError px) -- | 'serve' two 'ApiHandler's at once. The first handler is used for@@ -151,7 +151,7 @@ -> ApiHandler p1 r -> ApiHandler p2 r -> Eff r ()-serveBoth px h1 h2 = receiveLoop px $ \mReq -> case mReq of+serveBoth px h1 h2 = receiveLoop px $ \case Left Nothing -> applyApiHandler px h1 (Terminate Nothing) Left (Just reason) -> applyApiHandler px h1 (Terminate (Just reason)) Right dyn -> ensureAllHandled
src/Control/Eff/Concurrent/Examples2.hs view
@@ -1,18 +1,20 @@ -- | Another complete example for the library module Control.Eff.Concurrent.Examples2 where -import Data.Dynamic-import Control.Eff-import qualified Control.Eff.Concurrent.Process.ForkIOScheduler as ForkIO-import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler as Pure-import Control.Eff.Concurrent-import Control.Eff.State.Strict-import Control.Monad+import Data.Dynamic+import Control.Eff+import qualified Control.Eff.Concurrent.Process.ForkIOScheduler+ as ForkIO+import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler+ as Pure+import Control.Eff.Concurrent+import Control.Eff.State.Strict+import Control.Monad main :: IO ()-main =- do ForkIO.defaultMain (counterExample SchedulerProxy)- Pure.defaultMain (counterExample SchedulerProxy)+main = do+ ForkIO.defaultMain (counterExample SchedulerProxy)+ Pure.defaultMain (counterExample SchedulerProxy) -- * First API @@ -30,48 +32,47 @@ data Observation Counter where CountChanged :: Integer -> Observation Counter deriving (Show, Typeable)- registerObserverMessage os = ObserveCounter os- forgetObserverMessage os = UnobserveCounter os+ registerObserverMessage = ObserveCounter+ forgetObserverMessage = UnobserveCounter logCounterObservations :: (SetMember Process (Process q) r, Member (Logs String) q)- => SchedulerProxy q -> Eff r (Server (CallbackObserver Counter))-logCounterObservations px =- spawnCallbackObserver px- (\fromSvr msg ->- do me <- self px- logMsg (show me- ++ " observed on: "- ++ show fromSvr- ++ ": "- ++ show msg)- return True)+ => SchedulerProxy q+ -> Eff r (Server (CallbackObserver Counter))+logCounterObservations px = spawnCallbackObserver+ px+ (\fromSvr msg -> do+ me <- self px+ logMsg (show me ++ " observed on: " ++ show fromSvr ++ ": " ++ show msg)+ return True+ ) -counterHandler :: forall r q .- ( Member (State (Observers Counter)) r- , Member (State Integer) r- , Member (Logs String) r- , SetMember Process (Process q) r)- => SchedulerProxy q- -> ApiHandler Counter r-counterHandler px =- ApiHandler @Counter handleCast handleCall (defaultTermination px)+counterHandler+ :: forall r q+ . ( Member (State (Observers Counter)) r+ , Member (State Integer) r+ , Member (Logs String) r+ , SetMember Process (Process q) r+ )+ => SchedulerProxy q+ -> ApiHandler Counter r+counterHandler px = ApiHandler @Counter handleCast+ handleCall+ (defaultTermination px) where- handleCast :: Api Counter 'Asynchronous -> Eff r ()- handleCast (ObserveCounter o) = do- addObserver o- handleCast (UnobserveCounter o) = do- removeObserver o- handleCast Inc = do- logMsg "Inc"- modify (+ (1 :: Integer))- currentCount <- get- notifyObservers px (CountChanged currentCount)- handleCall :: Api Counter ('Synchronous x) -> (x -> Eff r ()) -> Eff r ()- handleCall Cnt reply = do- c <- get- logMsg ("Cnt is " ++ show c)- reply c+ handleCast :: Api Counter 'Asynchronous -> Eff r ()+ handleCast (ObserveCounter o) = addObserver o+ handleCast (UnobserveCounter o) = removeObserver o+ handleCast Inc = do+ logMsg "Inc"+ modify (+ (1 :: Integer))+ currentCount <- get+ notifyObservers px (CountChanged currentCount)+ handleCall :: Api Counter ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r ()+ handleCall Cnt reply = do+ c <- get+ logMsg ("Cnt is " ++ show c)+ reply c -- * Second API @@ -83,56 +84,60 @@ deriving instance Show (Api PocketCalc x) -pocketCalcHandler :: forall r q .- ( Member (State Integer) r- , Member (Logs String) r- , SetMember Process (Process q) r)- => SchedulerProxy q- -> ApiHandler PocketCalc r-pocketCalcHandler px =- ApiHandler @PocketCalc handleCast handleCall (defaultTermination px)+pocketCalcHandler+ :: forall r q+ . ( Member (State Integer) r+ , Member (Logs String) r+ , SetMember Process (Process q) r+ )+ => SchedulerProxy q+ -> ApiHandler PocketCalc r+pocketCalcHandler px = ApiHandler @PocketCalc handleCast+ handleCall+ (defaultTermination px) where- handleCast :: Api PocketCalc 'Asynchronous -> Eff r ()- handleCast (AAdd x) = do- logMsg ("AsyncAdd " ++ show x)- modify (+ x)- c <- get @Integer- logMsg ("Accumulator is " ++ show c)- handleCall :: Api PocketCalc ('Synchronous x) -> (x -> Eff r ()) -> Eff r ()- handleCall (Add x) reply = do- logMsg ("Add " ++ show x)- modify (+ x)- c <- get- logMsg ("Accumulator is " ++ show c)- reply c+ handleCast :: Api PocketCalc 'Asynchronous -> Eff r ()+ handleCast (AAdd x) = do+ logMsg ("AsyncAdd " ++ show x)+ modify (+ x)+ c <- get @Integer+ logMsg ("Accumulator is " ++ show c)+ handleCall :: Api PocketCalc ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r ()+ handleCall (Add x) reply = do+ logMsg ("Add " ++ show x)+ modify (+ x)+ c <- get+ logMsg ("Accumulator is " ++ show c)+ reply c -serverLoop :: forall r q .- ( Member (Logs String) r- , SetMember Process (Process q) r)- => SchedulerProxy q- -> Eff r ()-serverLoop px = do- evalState @Integer- 0- (manageObservers @Counter- (serveBoth px- (counterHandler px)- (pocketCalcHandler px)))+serverLoop+ :: forall r q+ . (Member (Logs String) r, SetMember Process (Process q) r)+ => SchedulerProxy q+ -> Eff r ()+serverLoop px = evalState @Integer+ 0+ (manageObservers @Counter+ (serveBoth px (counterHandler px) (pocketCalcHandler px))+ ) -- ** Counter client-counterExample :: ( Member (Logs String) r- , Member (Logs String) q- , SetMember Process (Process q) r)- => SchedulerProxy q- -> Eff r ()+counterExample+ :: ( Member (Logs String) r+ , Member (Logs String) q+ , SetMember Process (Process q) r+ )+ => SchedulerProxy q+ -> Eff r () counterExample px = do- let cnt sv = do r <- call px sv Cnt- logMsg (show sv ++ " " ++ show r)+ let cnt sv = do+ r <- call px sv Cnt+ logMsg (show sv ++ " " ++ show r) pid1 <- spawn (serverLoop px) pid2 <- spawn (serverLoop px)- let cntServer1 = asServer @Counter pid1- cntServer2 = asServer @Counter pid2+ let cntServer1 = asServer @Counter pid1+ cntServer2 = asServer @Counter pid2 calcServer1 = asServer @PocketCalc pid1 calcServer2 = asServer @PocketCalc pid2 cast px cntServer1 Inc@@ -143,7 +148,7 @@ registerObserver px co1 cntServer1 registerObserver px co2 cntServer2 cast px calcServer1 (AAdd 12313)- cast px cntServer1 Inc+ cast px cntServer1 Inc cnt cntServer1 cast px cntServer2 Inc cnt cntServer2
src/Control/Eff/Concurrent/Process.hs view
@@ -265,8 +265,7 @@ . (HasCallStack, SetMember Process (Process q) r) => SchedulerProxy q -> Eff r Dynamic-receiveMessage _ = do- executeAndResume ReceiveMessage+receiveMessage _ = executeAndResume ReceiveMessage -- | Receive and cast the message to some 'Typeable' instance. receiveMessageAs
src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs view
@@ -272,8 +272,7 @@ lift (getLogChannelIO s) getLogChannelIO :: SchedulerVar -> IO (LogChannel String)-getLogChannelIO s =- (view logChannel) <$> atomically (readTVar (fromSchedulerVar s))+getLogChannelIO s = view logChannel <$> readTVarIO (fromSchedulerVar s) overProcessInfo :: HasSchedulerIO r@@ -316,7 +315,7 @@ -> Eff SchedulerIO (Either SchedulerError ()) scheduleProcessWithCleanup shutdownAction processAction = withMessageQueue (\cleanUpAction pinfo -> handle_relay- (\x -> return x)+ return (go (pinfo ^. processId)) (processAction cleanUpAction (pinfo ^. processId)) )@@ -332,7 +331,7 @@ psVar <- getSchedulerTVar eHasShutdowReq <- lift (do- p <- atomically (readTVar psVar)+ p <- readTVarIO psVar let mPinfo = p ^. processTable . at pid case mPinfo of Just !pinfo -> atomically@@ -363,7 +362,7 @@ lift ( Right <$> (do- p <- atomically (readTVar psVar)+ p <- readTVarIO psVar let mto = p ^. processTable . at toPid case mto of Just toProc -> do@@ -382,12 +381,12 @@ lift ( Right <$> (do- p <- atomically (readTVar psVar)+ p <- readTVarIO psVar let mto = p ^. processTable . at toPid case mto of Just toProc -> atomically $ do writeTVar (toProc ^. shutdownRequested) True- writeTQueue (toProc ^. messageQ) Nothing+ writeTQueue (toProc ^. messageQ) Nothing -- this wakes up a receiver return True Nothing -> return False )@@ -406,7 +405,7 @@ case emq of Left e -> k (OnError (show @SchedulerError e)) Right mq -> do- emdynMsg <- lift (Right <$> (atomically (readTQueue mq)))+ emdynMsg <- lift (Right <$> atomically (readTQueue mq)) k (either (OnError . show @SchedulerError) (maybe RetryLastAction ResumeWith)@@ -421,13 +420,12 @@ lift Concurrent.yield k (ResumeWith ()) - go _pid Shutdown _k = do- invokeShutdownAction shutdownAction (Right ())+ go _pid Shutdown _k = invokeShutdownAction shutdownAction (Right ()) - go _pid (ExitWithError msg) _k = do+ go _pid (ExitWithError msg) _k = invokeShutdownAction shutdownAction (Left (ProcessExitError msg)) - go _pid (RaiseError msg) _k = do+ go _pid (RaiseError msg) _k = invokeShutdownAction shutdownAction (Left (ProcessExitError msg)) data ShutdownAction =@@ -508,14 +506,13 @@ lift (overSchedulerIO psVar stAction) overSchedulerIO :: STM.TVar Scheduler -> Mtl.StateT Scheduler STM.STM a -> IO a-overSchedulerIO psVar stAction = do- STM.atomically- (do- ps <- STM.readTVar psVar- (result, psModified) <- Mtl.runStateT stAction ps- STM.writeTVar psVar psModified- return result- )+overSchedulerIO psVar stAction = STM.atomically+ (do+ ps <- STM.readTVar psVar+ (result, psModified) <- Mtl.runStateT stAction ps+ STM.writeTVar psVar psModified+ return result+ ) getSchedulerTVar :: HasSchedulerIO r => Eff r (TVar Scheduler) getSchedulerTVar = fromSchedulerVar <$> ask
src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs view
@@ -72,7 +72,7 @@ => (l -> m ()) -> Eff (ConsProcess '[Logs l, Lift m]) a -> m (Either String a)-scheduleIOWithLogging handleLog e = scheduleIO (handleLogsWith handleLog) e+scheduleIOWithLogging handleLog = scheduleIO (handleLogsWith handleLog) -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. --@@ -100,7 +100,11 @@ -> m (Either String a) scheduleM runEff yieldEff e = do y <- runAsCoroutinePure runEff e- handleProcess runEff yieldEff 1 (Map.singleton 0 Seq.empty) (Seq.singleton (y, 0))+ handleProcess runEff+ yieldEff+ 1+ (Map.singleton 0 Seq.empty)+ (Seq.singleton (y, 0)) -- | Internal data structure that is part of the coroutine based scheduler -- implementation.@@ -132,12 +136,17 @@ -> Map.Map ProcessId (Seq Dynamic) -> Seq (OnYield r finalResult, ProcessId) -> m (Either String finalResult)-handleProcess _runEff _yieldEff _newPid _msgQs Empty = return $ Left "no main process"+handleProcess _runEff _yieldEff _newPid _msgQs Empty =+ return $ Left "no main process" handleProcess runEff yieldEff !newPid !msgQs allProcs@((!processState, !pid) :<| rest) = let handleExit res = if pid == 0 then return res- else handleProcess runEff yieldEff newPid (msgQs & at pid .~ Nothing) rest+ else handleProcess runEff+ yieldEff+ newPid+ (msgQs & at pid .~ Nothing)+ rest in case processState of OnDone r -> handleExit (Right r)@@ -174,11 +183,12 @@ return (nextTargetState, tPid) nextTargets <- runEff $ traverse deliverTheGoodNews targets nextK <- runEff $ k (ResumeWith targetFound)- handleProcess runEff- yieldEff- newPid- msgQs- (allButTarget Seq.>< (nextTargets :|> (nextK, pid)))+ handleProcess+ runEff+ yieldEff+ newPid+ msgQs+ (allButTarget Seq.>< (nextTargets :|> (nextK, pid))) OnSelf k -> do@@ -193,10 +203,10 @@ OnSend toPid msg k -> do nextK <- runEff $ k (ResumeWith (msgQs ^. at toPid . to isJust)) handleProcess runEff- yieldEff- newPid- (msgQs & at toPid . _Just %~ (:|> msg))- (rest :|> (nextK, pid))+ yieldEff+ newPid+ (msgQs & at toPid . _Just %~ (:|> msg))+ (rest :|> (nextK, pid)) recv@(OnRecv k) -> case msgQs ^. at pid of Nothing -> do@@ -207,24 +217,28 @@ nextK <- runEff $ k (OnError ("Process " ++ show pid ++ " deadlocked!")) handleProcess runEff yieldEff newPid msgQs (rest :|> (nextK, pid))- else handleProcess runEff yieldEff newPid msgQs (rest :|> (recv, pid))+ else handleProcess runEff+ yieldEff+ newPid+ msgQs+ (rest :|> (recv, pid)) Just (nextMessage :<| restMessages) -> do nextK <- runEff $ k (ResumeWith nextMessage) handleProcess runEff- yieldEff- newPid- (msgQs & at pid . _Just .~ restMessages)- (rest :|> (nextK, pid))+ yieldEff+ newPid+ (msgQs & at pid . _Just .~ restMessages)+ (rest :|> (nextK, pid)) OnSpawn f k -> do nextK <- runEff $ k (ResumeWith newPid) fk <- runAsCoroutinePure runEff (f >> exitNormally SP) handleProcess runEff- yieldEff- (newPid + 1)- (msgQs & at newPid .~ Just Seq.empty)- (rest :|> (nextK, pid) :|> (fk, newPid))+ yieldEff+ (newPid + 1)+ (msgQs & at newPid ?~ Seq.empty)+ (rest :|> (nextK, pid) :|> (fk, newPid)) runAsCoroutinePure :: forall v r m
src/Control/Eff/Log.hs view
@@ -4,8 +4,8 @@ -- * Logging Effect Logs(..) , logMsg- , foldLog- , foldLogFast+ , interceptLogging+ , foldLogMessages , module ExtLog , captureLogs , ignoreLogs@@ -51,6 +51,8 @@ import Data.String import Data.Typeable ++ -- | Logging effect type, parameterized by a log message type. data Logs message a where LogMsg :: message -> Logs message ()@@ -59,7 +61,8 @@ logMsg :: Member (Logs m) r => m -> Eff r () logMsg msg = send (LogMsg msg) --- | Change, add or remove log messages.+-- | Change, add or remove log messages and perform arbitrary actions upon+-- intercepting a log message. -- -- Requirements: --@@ -75,36 +78,25 @@ -- Approach: Install a callback that sneaks into to log message -- sending/receiving, to intercept the messages and execute some code and then -- return a new message.-foldLog+interceptLogging :: forall r m a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a-foldLog interceptor effect = interpose return go effect+interceptLogging interceptor = interpose return go where go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y go (LogMsg m) k = do interceptor m k () --- | Change, add or remove log messages without side effects, faster than--- 'foldLog'.------ Requirements:------ * Tests run fast in unit tests so travis won't time out------ * Drop debug logs------ * /Grep like/ log filtering+-- | Intercept logging to change, add or remove log messages. ----- Approach: Install a callback that sneaks into to log message--- sending/receiving, to intercept the messages and execute some code and then--- return a new message.-foldLogFast+-- This is without side effects, hence faster than 'interceptLogging'.+foldLogMessages :: forall r m a f . (Foldable f, Member (Logs m) r) => (m -> f m) -> Eff r a -> Eff r a-foldLogFast interceptor effect = interpose return go effect+foldLogMessages interceptor = interpose return go where go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y go (LogMsg m) k = do@@ -114,11 +106,9 @@ -- | Capture all log messages in a 'Seq' (strict). captureLogs :: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message)-captureLogs actionThatLogs = Eff.handle_relay_s- Seq.empty- (\logs result -> return (result, logs))- handleLogs- actionThatLogs+captureLogs = Eff.handle_relay_s Seq.empty+ (\logs result -> return (result, logs))+ handleLogs where handleLogs :: NFData message@@ -130,7 +120,7 @@ -- | Throw away all log messages. ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a-ignoreLogs actionThatLogs = Eff.handle_relay return handleLogs actionThatLogs+ignoreLogs = Eff.handle_relay return handleLogs where handleLogs :: Logs m x -> Arr r x y -> Eff r y handleLogs (LogMsg _) k = k ()@@ -185,10 +175,9 @@ => LogChannel message -> Eff (Logs message ': r) a -> Eff r a-logToChannel logChan actionThatLogs = do- handleLogsWithLoggingTHandler- actionThatLogs- (\withHandler -> withHandler (logChannelPutIO logChan))+logToChannel logChan actionThatLogs = handleLogsWithLoggingTHandler+ actionThatLogs+ (\withHandler -> withHandler (logChannelPutIO logChan)) -- | Enqueue a log message into a log channel logChannelPutIO :: LogChannel message -> message -> IO ()@@ -287,7 +276,7 @@ if f closeLogMessage then joinLogChannel (Just closeLogMessage) lc else joinLogChannel Nothing lc-joinLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) = do+joinLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) = throwTo thread (JoinLogChannelException closeLogMessage) -- | Close a log channel quickly, without logging messages already in the queue.@@ -326,8 +315,8 @@ -- | Wrap 'LogChannel' creation and destruction around a monad action in -- 'bracket'y manner. This function uses 'joinLogChannel', so en-queued messages--- are flushed on exit. The resulting action in in the 'LoggingT' monad, which--- is essentially a reader for the log handler function.+-- are flushed on exit. The resulting action is a 'LoggingT' action, which+-- is essentially a reader for a log handler function in 'IO'. logChannelBracket :: (Show message, Typeable message) => Int -- ^ Size of the log message input queue. If the queue is full, message
+ src/Control/Eff/Log/MessageFactory.hs view
@@ -0,0 +1,56 @@+module Control.Eff.Log.MessageFactory+ ( mkLogMsg+ , MessageFactory()+ , MessageFactoryReader+ , withLogMessageFactory+ , composeMessageFactories+ , localMessageFactory+ )+where++import Control.Eff+import Control.Eff.Log hiding ( Severity )+import Control.Eff.Reader.Strict+import Control.Eff.Lift+import Control.Monad.IO.Class+import Data.Default++newtype MessageFactory m =+ MessageFactory { runMessageFactory :: IO m}++type MessageFactoryReader m = Reader (MessageFactory m)++mkLogMsg+ :: forall m io e+ . ( Member (Logs m) e+ , MonadIO io+ , SetMember Lift (Lift io) e+ , Member (MessageFactoryReader m) e+ )+ => (m -> m)+ -> Eff e ()+mkLogMsg f = ask >>= lift . liftIO . runMessageFactory >>= logMsg . f++localMessageFactory+ :: forall m e a+ . (Member (MessageFactoryReader m) e)+ => IO m+ -> Eff e a+ -> Eff e a+localMessageFactory = local . const . MessageFactory++composeMessageFactories+ :: forall m e a+ . (Member (MessageFactoryReader m) e)+ => (m -> IO m)+ -> Eff e a+ -> Eff e a+composeMessageFactories f2 =+ local (\(MessageFactory f1) -> MessageFactory (f1 >>= f2))++withLogMessageFactory+ :: forall m io e a+ . (Member (Logs m) e, Default m, MonadIO io, SetMember Lift (Lift io) e)+ => Eff (MessageFactoryReader m ': e) a+ -> Eff e a+withLogMessageFactory = runReader (MessageFactory (return def))
+ src/Control/Eff/Log/Syslog.hs view
@@ -0,0 +1,249 @@+-- | An RFC 5434 inspired log message and convenience functions for+-- logging them. TODO document+module Control.Eff.Log.Syslog+ ( Severity(fromSeverity)+ , emergencySeverity+ , alertSeverity+ , criticalSeverity+ , errorSeverity+ , warningSeverity+ , noticeSeverity+ , informationalSeverity+ , debugSeverity+ , Facility(fromFacility)+ , kernelMessages+ , userLevelMessages+ , mailSystem+ , systemDaemons+ , securityAuthorizationMessages4+ , linePrinterSubsystem+ , networkNewsSubsystem+ , uucpSubsystem+ , clockDaemon+ , securityAuthorizationMessages10+ , ftpDaemon+ , ntpSubsystem+ , logAuditFacility+ , logAlertFacility+ , clockDaemon2+ , local0+ , local1+ , local2+ , local3+ , local4+ , local5+ , local6+ , local7+ , LogMessage(..)+ , lmFacility+ , lmSeverity+ , lmTimestamp+ , lmHostname+ , lmAppname+ , lmProcessId+ , lmMessageId+ , lmStructuredData+ , lmSrcLoc+ , lmMessage+ , StructuredDataElement(..)+ , sdElementId+ , sdElementParameters+ , addSyslogTimestamps+ , syslogMsg+ , withSyslog+ )+where++import Data.Time.Clock+import Data.Time.Format+import Control.Lens+import Control.Eff+import Control.Eff.Lift+import Control.Eff.Log hiding ( Severity )+import GHC.Stack+import Data.Default+import Control.Eff.Log.MessageFactory+import Control.DeepSeq+import Control.Monad.IO.Class+import Data.Maybe+import GHC.Generics++data LogMessage =+ LogMessage { _lmFacility :: Facility+ , _lmSeverity :: Severity+ , _lmTimestamp :: Maybe UTCTime+ , _lmHostname :: Maybe String+ , _lmAppname :: Maybe String+ , _lmProcessId :: Maybe String+ , _lmMessageId :: Maybe String+ , _lmStructuredData :: [StructuredDataElement]+ , _lmSrcLoc :: Maybe SrcLoc+ , _lmMessage :: String}+ deriving (Eq, Generic)++instance Show LogMessage where+ show (LogMessage f s ts hn an pid mi sd loc msg) =+ unwords+ ( ("<" ++ show (fromSeverity s + fromFacility f * 8) ++ ">" ++ "1")+ : maybe "-" (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))) ts+ : fromMaybe "-" hn+ : fromMaybe "-" an+ : fromMaybe "-" pid+ : fromMaybe "-" mi+ : (if null sd then "-" else show sd)+ : (if null msg then [] else msg : maybe [] (pure . prettySrcLoc) loc))++instance NFData LogMessage++data StructuredDataElement =+ StructuredDataElement {_sdElementId :: String+ ,_sdElementParameters :: [(String, Maybe String)]}+ deriving (Eq, Ord, Show, Generic)++instance NFData StructuredDataElement++instance Default LogMessage where+ def = LogMessage local7 debugSeverity def def def def def def def ""++-- | An rfc 5424 severity+newtype Severity = Severity {fromSeverity :: Int}+ deriving (Eq, Ord, Show, Generic, NFData)++emergencySeverity :: Severity+emergencySeverity = Severity 0++alertSeverity :: Severity+alertSeverity = Severity 1++criticalSeverity :: Severity+criticalSeverity = Severity 2++errorSeverity :: Severity+errorSeverity = Severity 3++warningSeverity :: Severity+warningSeverity = Severity 4++noticeSeverity :: Severity+noticeSeverity = Severity 5++informationalSeverity :: Severity+informationalSeverity = Severity 6++debugSeverity :: Severity+debugSeverity = Severity 7++-- | An rfc 5424 facility+newtype Facility = Facility {fromFacility :: Int}+ deriving (Eq, Ord, Show, Generic, NFData)++kernelMessages :: Facility+kernelMessages = Facility 0++userLevelMessages :: Facility+userLevelMessages = Facility 1++mailSystem :: Facility+mailSystem = Facility 2++systemDaemons :: Facility+systemDaemons = Facility 3++securityAuthorizationMessages4 :: Facility+securityAuthorizationMessages4 = Facility 4++linePrinterSubsystem :: Facility+linePrinterSubsystem = Facility 6++networkNewsSubsystem :: Facility+networkNewsSubsystem = Facility 7++uucpSubsystem :: Facility+uucpSubsystem = Facility 8++clockDaemon :: Facility+clockDaemon = Facility 9++securityAuthorizationMessages10 :: Facility+securityAuthorizationMessages10 = Facility 10++ftpDaemon :: Facility+ftpDaemon = Facility 11++ntpSubsystem :: Facility+ntpSubsystem = Facility 12++logAuditFacility :: Facility+logAuditFacility = Facility 13++logAlertFacility :: Facility+logAlertFacility = Facility 14++clockDaemon2 :: Facility+clockDaemon2 = Facility 15++local0 :: Facility+local0 = Facility 16++local1 :: Facility+local1 = Facility 17++local2 :: Facility+local2 = Facility 18++local3 :: Facility+local3 = Facility 19++local4 :: Facility+local4 = Facility 20++local5 :: Facility+local5 = Facility 21++local6 :: Facility+local6 = Facility 22++local7 :: Facility+local7 = Facility 23++makeLenses ''StructuredDataElement+makeLenses ''LogMessage++addSyslogTimestamps+ :: ( MonadIO io+ , SetMember Lift (Lift io) e+ , Member (Logs LogMessage) e+ , Member (MessageFactoryReader LogMessage) e+ )+ => Eff e a+ -> Eff e a+addSyslogTimestamps = composeMessageFactories $ \m -> do+ now <- getCurrentTime+ return (m & lmTimestamp ?~ now)++syslogMsg+ :: ( HasCallStack+ , MonadIO io+ , SetMember Lift (Lift io) e+ , Member (Logs LogMessage) e+ , Member (MessageFactoryReader LogMessage) e+ )+ => (LogMessage -> LogMessage)+ -> Eff e ()+syslogMsg f = mkLogMsg (f . setCallStack callStack)+ where+ setCallStack :: CallStack -> LogMessage -> LogMessage+ setCallStack cs m = case getCallStack cs of+ [] -> m+ (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc++withSyslog+ :: forall io e a+ . ( Member (Logs LogMessage) e+ , Default LogMessage+ , MonadIO io+ , SetMember Lift (Lift io) e+ )+ => Eff (MessageFactoryReader LogMessage ': e) a+ -> Eff e a+withSyslog = withLogMessageFactory . addSyslogTimestamps
stack.yaml view
@@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml"-resolver: lts-11.9+resolver: lts-12.9 # User packages to be built. # Various formats can be used as shown in the example below.@@ -40,8 +40,7 @@ # 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+- extensible-effects-3.1.0.1 # Override default flag values for local packages and extra-deps # flags: {}@@ -54,7 +53,7 @@ # # Require a specific version of stack, using version ranges # require-stack-version: -any # Default-require-stack-version: ">=1.6"+require-stack-version: ">=1.7" # # Override the architecture used by stack, especially useful on Windows # arch: i386
+ test/LoggingTests.hs view
@@ -0,0 +1,35 @@+module LoggingTests where++import Control.Eff+import Control.Eff.Log+import Test.Tasty+import Test.Tasty.HUnit+import Common+import Control.DeepSeq+import qualified Data.Sequence as Seq+++demo :: Member (Logs String) e => Eff e ()+demo = do+ logMsg "jo"+ logMsg "test 123"+++test_loggingInterception :: TestTree+test_loggingInterception = setTravisTestOptions $ testGroup+ "Intercept Logging"+ [ testCase "Convert Log Message Type" $ do+ let (((), strLogs), otherLogs) = run+ (captureLogs @OtherLogMsg+ (captureLogs @String (interceptLogging toOtherLogMsg demo))+ )+ assertEqual "string logs must be empty" Seq.empty strLogs+ assertEqual "other logs should contain all logging"+ (Seq.fromList [OtherLogMsg "jo", OtherLogMsg "test 123"])+ otherLogs+ ]++newtype OtherLogMsg = OtherLogMsg String deriving (Eq, NFData, Show)++toOtherLogMsg :: ('[Logs String, Logs OtherLogMsg] <:: e) => String -> Eff e ()+toOtherLogMsg = logMsg . OtherLogMsg