diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,41 @@ [1]: http://semver.org/spec/v2.0.0.html [2]: https://github.com/roman/capataz/releases +## v0.1.0.1 + +* Bump bounds of `async` dependency + +## v0.1.0.0 Who supervises the supervisor? + +**BREAKING CHANGES** + +* Introduction of the `Process` type which is composed of both `Supervisor` and + `Worker` types +* Replace `defWorkerSpec` in favor of `workerSpec` and `workerSpecWithDefaults` + to build static workers +* Replace of `defWorkerOptions` in favor of `buildWorkerOptions` and + `buildWorkerOptionsWithDefaults` to build dynamic workers +* Replace `terminateWorker` in favor of `terminateProcess` +* Add `supervisorSpec`, `supervisorSpecWithDefaults` to build static supervision + trees +* Add `forkSupervisor`, `buildSupervisorOptions` and + `buildSupervisorOptionsWithDefaults` to build dynamic supervision trees +* Replace usage of default records semantics in favor of Lenses +* Add `joinCapatazThread` to avoid providing direct access to async of root + supervision tree +* Add `getSupervisorProcessId` to access the `ProcessId` of a given `Supervisor` + record (for dynamic termination) +* Add `getSupervisorAsync` to access the `Async ()` record of a supervisor + process thread +* Add `getCapatazTeardown` to access the `Teardown` record of the capataz system +* Move `CapatazEvent` records to new module `Control.Concurrent.Capataz.Event` + to avoid requiring `DuplicateRecordFields` extension on API users +* Remove `WorkerAction` alias as it is used for library development + documentation +* Add capataz-repo-watcher example to showcase static supervision trees +* Update capataz-simple-example unix-process example +* `forkCapataz` signature now requires name for root supervisor + ## v0.0.0.2 * Bump bounds of `tasty` dependency diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ * [Documentation](#documentation) * [Development](#development) -## Raison d'etre +## Raison d'être As time progresses, I've come to love developing concurrent applications in Haskell, its API (STM, MVars, etc.) and light threading RTS bring a lot to the @@ -91,12 +91,15 @@ ## Development [![Build Status](https://travis-ci.org/roman/Haskell-capataz.svg?branch=master)](https://travis-ci.org/roman/Haskell-capataz) -[![Github](https://img.shields.io/github/commits-since/roman/haskell-capataz/v0.0.0.2.svg)](https://img.shields.io/github/commits-since/roman/haskell-capataz/v0.0.0.2.svg) +[![Github](https://img.shields.io/github/commits-since/roman/haskell-capataz/v0.1.0.0.svg)](https://img.shields.io/github/commits-since/roman/haskell-capataz/v0.1.0.0.svg) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/capataz.svg)](http://packdeps.haskellers.com/feed?needle=capataz) Follow the [developer guidelines](https://romanandreg.gitbooks.io/capataz/content/developer-guidelines.html) -## In next release +## In future releases -* Add support for supervising supervisors +* Replace Protolude in favor of RIO +* Documentation of performance analysis +* Documentation improvements +* capataz-dashboard package that provides web-ui with Supervisor statistics * Ensure unit tests always finish on all concurrent scenarios (dejafu experiment) diff --git a/capataz.cabal b/capataz.cabal --- a/capataz.cabal +++ b/capataz.cabal @@ -1,5 +1,5 @@ name: capataz -version: 0.1.0.0 +version: 0.1.0.1 cabal-version: >=1.10 build-type: Simple license: MIT @@ -50,7 +50,7 @@ Control.Concurrent.Capataz.Internal.Util Control.Concurrent.Capataz.Internal.Worker build-depends: - async >=2.1.1.1 && <2.2, + async >=2.1.1.1 && <2.3, base >=4.10.1.0 && <4.11, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, @@ -75,7 +75,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - async >=2.1.1.1 && <2.2, + async >=2.1.1.1 && <2.3, base >=4.10.1.0 && <4.11, bytestring >=0.10.8.2 && <0.11, capataz -any, diff --git a/src/Control/Concurrent/Capataz.hs b/src/Control/Concurrent/Capataz.hs --- a/src/Control/Concurrent/Capataz.hs +++ b/src/Control/Concurrent/Capataz.hs @@ -81,6 +81,6 @@ import qualified Control.Concurrent.Capataz.Internal.Core import qualified Control.Concurrent.Capataz.Internal.Types +import Control.Concurrent.Capataz.Lens ((&), (.~)) import qualified Control.Concurrent.Capataz.Lens import qualified Control.Teardown -import Control.Concurrent.Capataz.Lens ((.~), (&)) diff --git a/src/Control/Concurrent/Capataz/Internal/Core.hs b/src/Control/Concurrent/Capataz/Internal/Core.hs --- a/src/Control/Concurrent/Capataz/Internal/Core.hs +++ b/src/Control/Concurrent/Capataz/Internal/Core.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + {-| This module contains: * Functions exported on the public API @@ -26,8 +27,7 @@ import Protolude import Control.Concurrent.MVar (newEmptyMVar, takeMVar) -import Control.Teardown (newTeardown) -import Control.Teardown (Teardown) +import Control.Teardown (Teardown, newTeardown) import Data.Time.Clock (getCurrentTime) import qualified Data.UUID.V4 as UUID (nextRandom) @@ -46,7 +46,7 @@ getSupervisor :: a -> Supervisor instance HasSupervisor Capataz where - getSupervisor (Capataz {capatazSupervisor}) = capatazSupervisor + getSupervisor Capataz {capatazSupervisor} = capatazSupervisor instance HasSupervisor Supervisor where getSupervisor = identity @@ -55,12 +55,13 @@ -- "Teardown" to shut down the system. The root supervisor monitors failures on -- process threads defined with "supervisorProcessSpecList" or created -- dynamically using "forkWorker" or "forkSupervisor". -forkCapataz :: (CapatazOptions -> CapatazOptions) -> IO Capataz -forkCapataz modOptionsFn = do +forkCapataz :: Text -> (CapatazOptions -> CapatazOptions) -> IO Capataz +forkCapataz capatazName modOptionsFn = do capatazId <- UUID.nextRandom supervisorId <- UUID.nextRandom let - capatazOptions@CapatazOptions { notifyEvent } = defCapatazOptions modOptionsFn + capatazOptions@CapatazOptions { notifyEvent } = + defCapatazOptions capatazName modOptionsFn supervisorOptions@SupervisorOptions { supervisorName } = Util.capatazOptionsToSupervisorOptions capatazOptions parentSupervisorEnv = ParentSupervisorEnv @@ -92,7 +93,6 @@ ControlAction{} -> panic "Capataz received a ControlAction message; bad implementation" - , notifyEvent } @@ -187,7 +187,7 @@ joinCapatazThread :: Capataz -> IO () joinCapatazThread Capataz { capatazSupervisor } = let Supervisor { supervisorAsync } = capatazSupervisor - in wait supervisorAsync + in wait supervisorAsync -- | Gets "Teardown" record of this capataz system. getCapatazTeardown :: Capataz -> Teardown @@ -198,8 +198,7 @@ -- NOTE: There is no way to get the "Async" value of the root supervisor; this -- is to avoid error scenarios. getSupervisorAsync :: Supervisor -> Async () -getSupervisorAsync Supervisor { supervisorAsync } = - supervisorAsync +getSupervisorAsync Supervisor { supervisorAsync } = supervisorAsync -- | Gets the process identifier of a Supervisor; normally used for termination. getSupervisorProcessId :: Supervisor -> ProcessId diff --git a/src/Control/Concurrent/Capataz/Internal/Supervisor.hs b/src/Control/Concurrent/Capataz/Internal/Supervisor.hs --- a/src/Control/Concurrent/Capataz/Internal/Supervisor.hs +++ b/src/Control/Concurrent/Capataz/Internal/Supervisor.hs @@ -90,8 +90,10 @@ handleControlAction :: SupervisorEnv -> ControlAction -> IO Bool handleControlAction env controlAction = case controlAction of ForkWorker { workerOptions, returnWorkerId } -> do - worker@Worker { workerId } <- - Worker.forkWorker (Util.toParentSupervisorEnv env) workerOptions Nothing + worker@Worker { workerId } <- Worker.forkWorker + (Util.toParentSupervisorEnv env) + workerOptions + Nothing Util.appendProcessToMap env (WorkerProcess worker) returnWorkerId workerId return True @@ -241,7 +243,10 @@ supervisorProcessSpecList ( \processSpec -> case processSpec of WorkerSpec workerOptions -> do - worker <- Worker.forkWorker (Util.toParentSupervisorEnv supervisorEnv) workerOptions Nothing + worker <- Worker.forkWorker + (Util.toParentSupervisorEnv supervisorEnv) + workerOptions + Nothing Util.appendProcessToMap supervisorEnv (WorkerProcess worker) SupervisorSpec childSupervisorOptions -> do @@ -409,9 +414,10 @@ restartWorker :: SupervisorEnv -> WorkerOptions -> WorkerId -> RestartCount -> IO Process restartWorker supervisorEnv workerOptions workerId restartCount = - WorkerProcess <$> Worker.forkWorker (Util.toParentSupervisorEnv supervisorEnv) - workerOptions - (Just (workerId, restartCount)) + WorkerProcess <$> Worker.forkWorker + (Util.toParentSupervisorEnv supervisorEnv) + workerOptions + (Just (workerId, restartCount)) -- | Starts a new Supervisor thread taking into account an existing -- "SupervisorId" and keeping a "RestartCount" to manage the parent Supervisor diff --git a/src/Control/Concurrent/Capataz/Internal/Types.hs b/src/Control/Concurrent/Capataz/Internal/Types.hs --- a/src/Control/Concurrent/Capataz/Internal/Types.hs +++ b/src/Control/Concurrent/Capataz/Internal/Types.hs @@ -2,19 +2,19 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} + {-| This module contains all the types used across all the other modules -} module Control.Concurrent.Capataz.Internal.Types where import Protolude -import Control.Concurrent.STM.TVar (TVar) -import Control.Teardown (ITeardown (..), Teardown) -import Data.Default (Default (..)) -import Data.HashMap.Strict (HashMap) -import Data.IORef (IORef) -import Data.Time.Clock (NominalDiffTime, UTCTime) -import Data.UUID (UUID) +import Control.Concurrent.STM.TVar (TVar) +import Control.Teardown (ITeardown (..), Teardown) +import Data.Default (Default (..)) +import Data.HashMap.Strict (HashMap) +import Data.IORef (IORef) +import Data.Time.Clock (NominalDiffTime, UTCTime) +import Data.UUID (UUID) type CapatazId = UUID type WorkerId = UUID @@ -212,7 +212,8 @@ -- data CapatazOptions = CapatazOptions { - supervisorIntensity :: !Int + supervisorName :: !SupervisorName + , supervisorIntensity :: !Int , supervisorPeriodSeconds :: !NominalDiffTime , supervisorRestartStrategy :: !SupervisorRestartStrategy , supervisorProcessSpecList :: ![ProcessSpec] @@ -530,21 +531,20 @@ -- This function is intended to be used in combination with "forkCapataz". -- defCapatazOptions - :: (CapatazOptions -> CapatazOptions) -- ^ Function to modify root supervisor - -- options + :: Text + -> (CapatazOptions -> CapatazOptions) -- ^ Function to modify root supervisor -> CapatazOptions -defCapatazOptions modFn = - modFn CapatazOptions - { - supervisorIntensity = 2 - , supervisorPeriodSeconds = 5 - , supervisorRestartStrategy = def - , supervisorProcessSpecList = [] - , supervisorProcessTerminationOrder = OldestFirst - , supervisorOnIntensityReached = return () - , supervisorOnFailure = const $ return () - , notifyEvent = const $ return () - } +defCapatazOptions supervisorName modFn = modFn CapatazOptions + { supervisorName + , supervisorIntensity = 2 + , supervisorPeriodSeconds = 5 + , supervisorRestartStrategy = def + , supervisorProcessSpecList = [] + , supervisorProcessTerminationOrder = OldestFirst + , supervisorOnIntensityReached = return () + , supervisorOnFailure = const $ return () + , notifyEvent = const $ return () + } -- | Builds a "ProcessSpec" record for a supervisor process with defaults from -- "supervisorSpecWithDefaults". This function allows overrides of these @@ -570,9 +570,8 @@ -- supervisorSpecWithDefaults :: SupervisorName -- ^ Name used for telemetry purposes - -> ProcessSpec -supervisorSpecWithDefaults sName = - supervisorSpec sName identity + -> ProcessSpec +supervisorSpecWithDefaults sName = supervisorSpec sName identity {-# INLINE supervisorSpecWithDefaults #-} -- | Builds a "ProcessSpec" record for a worker process with defaults from @@ -583,7 +582,7 @@ -- workerSpec :: WorkerName -- ^ Name used for telemetry purposes - -> (IO ()) -- ^ IO sub-routine to be supervised + -> IO () -- ^ IO sub-routine to be supervised -> (WorkerOptions -> WorkerOptions) -- ^ Function to modify default worker -- options -> ProcessSpec @@ -598,10 +597,9 @@ -- workerSpecWithDefaults :: WorkerName -- ^ Name used for telemetry purposes - -> (IO ()) -- ^ IO sub-routine to be supervised + -> IO () -- ^ IO sub-routine to be supervised -> ProcessSpec -workerSpecWithDefaults wName wAction = - workerSpec wName wAction identity +workerSpecWithDefaults wName wAction = workerSpec wName wAction identity {-# INLINE workerSpecWithDefaults #-} -- | Builds a "SupervisorOptions" record with defaults from @@ -641,8 +639,7 @@ buildSupervisorOptionsWithDefaults :: SupervisorName -- ^ Name used for telemetry purposes -> SupervisorOptions -buildSupervisorOptionsWithDefaults = - flip buildSupervisorOptions identity +buildSupervisorOptionsWithDefaults = flip buildSupervisorOptions identity {-# INLINE buildSupervisorOptionsWithDefaults #-} -- | Builds a "WorkerOptions" record, keeps the defaults from @@ -653,7 +650,7 @@ -- buildWorkerOptions :: WorkerName -- ^ Name used for telemetry purposes - -> (IO ()) -- ^ IO sub-routine to be supervised + -> IO () -- ^ IO sub-routine to be supervised -> (WorkerOptions -> WorkerOptions) -- ^ Function to modify default worker -- options -> WorkerOptions @@ -687,7 +684,7 @@ -- buildWorkerOptionsWithDefaults :: WorkerName -- ^ Name used for telemetry purposes - -> (IO ()) -- ^ IO sub-routine to be supervised + -> IO () -- ^ IO sub-routine to be supervised -> WorkerOptions buildWorkerOptionsWithDefaults wName wAction = buildWorkerOptions wName wAction identity diff --git a/src/Control/Concurrent/Capataz/Internal/Util.hs b/src/Control/Concurrent/Capataz/Internal/Util.hs --- a/src/Control/Concurrent/Capataz/Internal/Util.hs +++ b/src/Control/Concurrent/Capataz/Internal/Util.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-| This module contains: @@ -163,8 +163,7 @@ -- | Utility function to transform a "CapatazOptions" record to a -- "SupervisorOptions" record. capatazOptionsToSupervisorOptions :: CapatazOptions -> SupervisorOptions -capatazOptionsToSupervisorOptions CapatazOptions {..} = - SupervisorOptions {supervisorName = "capataz-root-supervisor", ..} +capatazOptionsToSupervisorOptions CapatazOptions {..} = SupervisorOptions {..} -- | Utility function to transform a "SupervisorEnv" record to a -- "ParentSupervisorEnv" record; used on functions where supervision of diff --git a/src/Control/Concurrent/Capataz/Internal/Worker.hs b/src/Control/Concurrent/Capataz/Internal/Worker.hs --- a/src/Control/Concurrent/Capataz/Internal/Worker.hs +++ b/src/Control/Concurrent/Capataz/Internal/Worker.hs @@ -21,7 +21,11 @@ -- | Decorates the given @IO ()@ sub-routine with failure handling workerMain - :: ParentSupervisorEnv -> WorkerOptions -> WorkerId -> RestartCount -> IO Worker + :: ParentSupervisorEnv + -> WorkerOptions + -> WorkerId + -> RestartCount + -> IO Worker workerMain env@ParentSupervisorEnv { supervisorNotify } workerOptions@WorkerOptions { workerName, workerAction } workerId restartCount = do workerCreationTime <- getCurrentTime diff --git a/test/testsuite/Control/Concurrent/Capataz/SupervisorTest.hs b/test/testsuite/Control/Concurrent/Capataz/SupervisorTest.hs --- a/test/testsuite/Control/Concurrent/Capataz/SupervisorTest.hs +++ b/test/testsuite/Control/Concurrent/Capataz/SupervisorTest.hs @@ -21,17 +21,22 @@ SUT.supervisorProcessSpecListL [ SUT.supervisorSpec "tree-1" - ( set SUT.supervisorProcessSpecListL - [ SUT.workerSpecWithDefaults "1-A" (forever $ threadDelay 10001000) - , SUT.workerSpecWithDefaults "1-B" (forever $ threadDelay 10001000) + ( set + SUT.supervisorProcessSpecListL + [ SUT.workerSpecWithDefaults "1-A" + (forever $ threadDelay 10001000) + , SUT.workerSpecWithDefaults "1-B" + (forever $ threadDelay 10001000) ] ) , SUT.supervisorSpec "tree-2" ( set SUT.supervisorProcessSpecListL - [ SUT.workerSpecWithDefaults "2-A" (forever $ threadDelay 10001000) - , SUT.workerSpecWithDefaults "2-B" (forever $ threadDelay 10001000) + [ SUT.workerSpecWithDefaults "2-A" + (forever $ threadDelay 10001000) + , SUT.workerSpecWithDefaults "2-B" + (forever $ threadDelay 10001000) ] ) ] @@ -51,7 +56,7 @@ , assertSupervisorStatusChanged SUT.Initializing SUT.Running ] , andP - [ assertSupervisorName "capataz-root-supervisor" + [ assertRootSupervisor , assertEventType SupervisorStatusChanged , assertSupervisorStatusChanged SUT.Initializing SUT.Running ] @@ -59,24 +64,19 @@ (const $ return ()) [] [ andP - [ assertSupervisorName "capataz-root-supervisor" + [ assertRootSupervisor , assertEventType SupervisorStatusChanged , assertSupervisorStatusChanged SUT.Running SUT.Halting ] - , andP - [ assertSupervisorName "capataz-root-supervisor" - , assertEventType ProcessTerminationStarted - ] + , andP [assertRootSupervisor, assertEventType ProcessTerminationStarted] , andP [assertSupervisorName "tree-1", assertWorkerTerminated "1-A"] , andP [assertSupervisorName "tree-1", assertWorkerTerminated "1-B"] , andP [assertSupervisorName "tree-2", assertWorkerTerminated "2-A"] , andP [assertSupervisorName "tree-2", assertWorkerTerminated "2-B"] , andP - [ assertSupervisorName "capataz-root-supervisor" - , assertEventType ProcessTerminationFinished - ] + [assertRootSupervisor, assertEventType ProcessTerminationFinished] , andP - [ assertSupervisorName "capataz-root-supervisor" + [ assertRootSupervisor , assertEventType SupervisorStatusChanged , assertSupervisorStatusChanged SUT.Halting SUT.Halted ] @@ -91,8 +91,9 @@ "tree-1" ( set SUT.supervisorIntensityL 1 . set SUT.supervisorPeriodSecondsL 10 - . set SUT.supervisorProcessSpecListL - [SUT.workerSpecWithDefaults "failing-worker" failingAction] + . set + SUT.supervisorProcessSpecListL + [SUT.workerSpecWithDefaults "failing-worker" failingAction] ) ] ) @@ -116,8 +117,9 @@ "tree-1" ( set SUT.supervisorIntensityL 1 . set SUT.supervisorPeriodSecondsL 10 - . set SUT.supervisorProcessSpecListL - [SUT.workerSpecWithDefaults "failing-worker" failingAction] + . set + SUT.supervisorProcessSpecListL + [SUT.workerSpecWithDefaults "failing-worker" failingAction] ) , SUT.supervisorSpec "tree-2" diff --git a/test/testsuite/Control/Concurrent/CapatazTest.hs b/test/testsuite/Control/Concurrent/CapatazTest.hs --- a/test/testsuite/Control/Concurrent/CapatazTest.hs +++ b/test/testsuite/Control/Concurrent/CapatazTest.hs @@ -288,8 +288,8 @@ capataz void $ SUT.terminateProcess "testing onFailure callback" - workerId - capataz + workerId + capataz ) [assertEventType ProcessTerminated] [] @@ -350,9 +350,10 @@ ) capataz - void $ SUT.terminateProcess "testing workerOnTermination callback" - workerId - capataz + void $ SUT.terminateProcess + "testing workerOnTermination callback" + workerId + capataz ) [ andP [ assertEventType ProcessCallbackExecuted @@ -380,9 +381,10 @@ ) capataz - void $ SUT.terminateProcess "testing workerOnTermination callback" - workerId - capataz + void $ SUT.terminateProcess + "testing workerOnTermination callback" + workerId + capataz ) [ andP [ assertEventType ProcessCallbackExecuted @@ -447,9 +449,10 @@ ) capataz - void $ SUT.terminateProcess "testing workerOnTermination callback" - workerId - capataz + void $ SUT.terminateProcess + "testing workerOnTermination callback" + workerId + capataz ) [ andP [ assertEventType ProcessCallbackExecuted @@ -594,7 +597,9 @@ (set SUT.workerRestartStrategyL SUT.Permanent) ) capataz - void $ SUT.terminateProcess "testing termination (1)" workerId capataz + void $ SUT.terminateProcess "testing termination (1)" + workerId + capataz ) [assertEventType ProcessTerminated, assertEventType ProcessRestarted] [] @@ -621,12 +626,12 @@ capataz void $ SUT.terminateProcess "testing termination (1)" - workerId - capataz + workerId + capataz waitWorkerTermination 1 void $ SUT.terminateProcess "testing termination (2)" - workerId - capataz + workerId + capataz waitWorkerTermination 2 ) [ assertEventType ProcessTerminated diff --git a/test/testsuite/Test/Util.hs b/test/testsuite/Test/Util.hs --- a/test/testsuite/Test/Util.hs +++ b/test/testsuite/Test/Util.hs @@ -209,6 +209,13 @@ assertCapatazFailedWith errorName = andP [assertEventType CapatazFailed, assertErrorType errorName] +rootSupervisorName :: Text +rootSupervisorName = "capataz-root-supervisor" + +assertRootSupervisor :: SUT.CapatazEvent -> Bool +assertRootSupervisor = assertSupervisorName rootSupervisorName + + -------------------------------------------------------------------------------- -- | Exception used to test failures inside Worker sub-routines @@ -293,11 +300,9 @@ [preSetupAssertion, postSetupAssertions, postTeardownAssertions] ) - capataz <- - SUT.forkCapataz - ( SUT.set SUT.onSystemEventL (trackEvent accRef eventStream) - . optionModFn - ) + capataz <- SUT.forkCapataz + rootSupervisorName + (SUT.set SUT.onSystemEventL (trackEvent accRef eventStream) . optionModFn) -- We check preSetup assertions are met before we execute the setup -- function. This serves to test initialization of capataz instance