summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Concurrent.hs
blob: e729d0cb096069953e20bfc1f4387c9078aa4bb8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{-# LANGUAGE FlexibleContexts #-}

-- | Propellor properties can be made to run concurrently, using this
-- module. This can speed up propellor, at the expense of using more CPUs
-- and other resources.
--
-- It's up to you to make sure that properties that you make run concurrently
-- don't implicitly depend on one-another. The worst that can happen
-- though, is that propellor fails to ensure some of the properties,
-- and tells you what went wrong.
--
-- Another potential problem is that output of concurrent properties could
-- interleave into a scrambled mess. This is mostly prevented; all messages
-- output by propellor are concurrency safe, including `errorMessage`,
-- `infoMessage`, etc. However, if you write a property that directly
-- uses `print` or `putStrLn`, you can still experience this problem.
--
-- Similarly, when properties run external commands, the command's output
-- can be a problem for concurrency. No need to worry;
-- `Propellor.Property.Cmd.createProcess` is concurrent output safe
-- (it actually uses `Propellor.Message.createProcessConcurrent`), and
-- everything else in propellor that runs external commands is built on top
-- of that. Of course, if you import System.Process and use it in a
-- property, you can bypass that and shoot yourself in the foot.
--
-- Finally, anything that directly accesses the tty can bypass
-- these protections. That's sometimes done for eg, password prompts.
-- A well-written property should avoid running interactive commands
-- anyway.

module Propellor.Property.Concurrent (
	concurrently,
	concurrentList,
	props,
	getNumProcessors,
	concurrentSatisfy,
) where

import Propellor.Base
import Propellor.Types.Core
import Propellor.Types.MetaTypes

import Control.Concurrent
import qualified Control.Concurrent.Async as A
import GHC.Conc (getNumProcessors)
import Control.Monad.RWS.Strict

-- | Ensures two properties concurrently.
--
-- >	& foo `concurrently` bar
--
-- To ensure three properties concurrently, just use this combinator twice:
--
-- >	& foo `concurrently` bar `concurrently` baz
concurrently
	:: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2))
	=> p1
	-> p2
	-> CombinedType p1 p2
concurrently p1 p2 = (combineWith go go p1 p2)
	`describe` d
  where
	d = getDesc p1 ++ " `concurrently` " ++ getDesc p2
	-- Increase the number of capabilities right up to the number of
	-- processors, so that A `concurrently` B `concurrently` C
	-- runs all 3 properties on different processors when possible.
	go (Just a1) (Just a2) = Just $ do
		n <- liftIO getNumProcessors
		withCapabilities n $
			concurrentSatisfy a1 a2
	go (Just a1) Nothing = Just a1
	go Nothing (Just a2) = Just a2
	go Nothing Nothing = Nothing

-- | Ensures all the properties in the list, with a specified amount of
-- concurrency.
-- 
-- > concurrentList (pure 2) "demo" $ props
-- >	& foo
-- >	& bar
-- >	& baz
--
-- The above example will run foo and bar concurrently, and once either of
-- those 2 properties finishes, will start running baz.
concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
concurrentList getn d (Props ps) = property d go `addChildren` ps
  where
	go = do
		n <- liftIO getn
		withCapabilities n $
			startworkers n =<< liftIO (newMVar ps)
	startworkers n q
		| n < 1 = return NoChange
		| n == 1 = worker q NoChange
		| otherwise = 
			worker q NoChange
				`concurrentSatisfy`
			startworkers (n-1) q
	worker q r = do
		v <- liftIO $ modifyMVar q $ \v -> case v of
			[] -> return ([], Nothing)
			(p:rest) -> return (rest, Just p)
		case v of
			Nothing -> return r
			Just p -> do
				hn <- asks hostName
				r' <- case getSatisfy p of
					Nothing -> return NoChange
					Just a -> actionMessageOn hn (getDesc p) a
				worker q (r <> r')

-- | Run an action with the number of capabiities increased as necessary to
-- allow running on the specified number of cores.
--
-- Never increases the number of capabilities higher than the actual number
-- of processors.
withCapabilities :: Int -> Propellor a -> Propellor a
withCapabilities n a = bracket setup cleanup (const a)
  where
	setup = do
		np <- liftIO getNumProcessors
		let n' = min n np
		c <- liftIO getNumCapabilities
		when (n' > c) $ 
			liftIO $ setNumCapabilities n'
		return c
	cleanup = liftIO . setNumCapabilities

-- | Running Propellor actions concurrently.
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy a1 a2 = do
	h <- ask
	((r1, w1), (r2, w2)) <- liftIO $
		runp a1 h `A.concurrently` runp a2 h
	tell (w1 <> w2)
	return (r1 <> r2)
  where
	runp a h = evalRWST (runWithHost (catchPropellor a)) h ()