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
|
{-# LANGUAGE FlexibleContexts #-}
-- | Note that any output of commands run by
-- concurrent properties will be scrambled together.
module Propellor.Property.Concurrent (
concurrently,
concurrentList,
props,
getNumProcessors,
withCapabilities,
concurrentSatisfy,
) where
import Propellor.Base
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import GHC.Conc (getNumProcessors)
import Control.Monad.RWS.Strict
-- | Ensures two properties concurrently.
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 a1 a2 = do
n <- liftIO getNumProcessors
withCapabilities n $
concurrentSatisfy a1 a2
-- | 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 :: IO Int -> Desc -> PropList -> Property HasInfo
concurrentList getn d (PropList ps) = infoProperty d go mempty 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
-- This use of propertySatisfy does not lose any
-- Info asociated with the property, because
-- concurrentList sets all the properties as
-- children, and so propigates their info.
Just p -> do
hn <- asks hostName
r' <- actionMessageOn hn
(propertyDesc p)
(propertySatisfy p)
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
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 ()
|
