diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/brittany.yaml b/brittany.yaml new file mode 100644 --- /dev/null +++ b/brittany.yaml @@ -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 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,5 @@ name: extensible-effects-concurrent -version: 0.4.0.0 +version: 0.5.0.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 @@ -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 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 @@ -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 diff --git a/src/Control/Eff/Concurrent/Examples2.hs b/src/Control/Eff/Concurrent/Examples2.hs --- a/src/Control/Eff/Concurrent/Examples2.hs +++ b/src/Control/Eff/Concurrent/Examples2.hs @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/src/Control/Eff/Log/MessageFactory.hs b/src/Control/Eff/Log/MessageFactory.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/MessageFactory.hs @@ -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)) diff --git a/src/Control/Eff/Log/Syslog.hs b/src/Control/Eff/Log/Syslog.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Log/Syslog.hs @@ -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 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-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 diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs new file mode 100644 --- /dev/null +++ b/test/LoggingTests.hs @@ -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