{-# 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 ()