{-# 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 -> CombinedType p1 p2
concurrently p1
p1 p2
p2 = (ResultCombiner -> ResultCombiner -> p1 -> p2 -> CombinedType p1 p2
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith ResultCombiner
go ResultCombiner
go p1
p1 p2
p2)
	CombinedType p1 p2 -> Desc -> CombinedType p1 p2
forall p. IsProp p => p -> Desc -> p
`describe` Desc
d
  where
	d :: Desc
d = p1 -> Desc
forall p. IsProp p => p -> Desc
getDesc p1
p1 Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
" `concurrently` " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ p2 -> Desc
forall p. IsProp p => p -> Desc
getDesc p2
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 :: ResultCombiner
go (Just Propellor Result
a1) (Just Propellor Result
a2) = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just (Propellor Result -> Maybe (Propellor Result))
-> Propellor Result -> Maybe (Propellor Result)
forall a b. (a -> b) -> a -> b
$ do
		Int
n <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
		Int -> Propellor Result -> Propellor Result
forall a. Int -> Propellor a -> Propellor a
withCapabilities Int
n (Propellor Result -> Propellor Result)
-> Propellor Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$
			Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy Propellor Result
a1 Propellor Result
a2
	go (Just Propellor Result
a1) Maybe (Propellor Result)
Nothing = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just Propellor Result
a1
	go Maybe (Propellor Result)
Nothing (Just Propellor Result
a2) = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just Propellor Result
a2
	go Maybe (Propellor Result)
Nothing Maybe (Propellor Result)
Nothing = Maybe (Propellor Result)
forall a. Maybe a
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 :: IO Int
-> Desc
-> Props (MetaTypes metatypes)
-> Property (MetaTypes metatypes)
concurrentList IO Int
getn Desc
d (Props [ChildProperty]
ps) = Desc -> Propellor Result -> Property (MetaTypes metatypes)
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property Desc
d Propellor Result
go Property (MetaTypes metatypes)
-> [ChildProperty] -> Property (MetaTypes metatypes)
forall p. IsProp p => p -> [ChildProperty] -> p
`addChildren` [ChildProperty]
ps
  where
	go :: Propellor Result
go = do
		Int
n <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getn
		Int -> Propellor Result -> Propellor Result
forall a. Int -> Propellor a -> Propellor a
withCapabilities Int
n (Propellor Result -> Propellor Result)
-> Propellor Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$
			Int -> MVar [ChildProperty] -> Propellor Result
forall t p.
(Ord t, Num t, IsProp p) =>
t -> MVar [p] -> Propellor Result
startworkers Int
n (MVar [ChildProperty] -> Propellor Result)
-> Propellor (MVar [ChildProperty]) -> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (MVar [ChildProperty]) -> Propellor (MVar [ChildProperty])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([ChildProperty] -> IO (MVar [ChildProperty])
forall a. a -> IO (MVar a)
newMVar [ChildProperty]
ps)
	startworkers :: t -> MVar [p] -> Propellor Result
startworkers t
n MVar [p]
q
		| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1 = Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
		| t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
1 = MVar [p] -> Result -> Propellor Result
forall p. IsProp p => MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
NoChange
		| Bool
otherwise = 
			MVar [p] -> Result -> Propellor Result
forall p. IsProp p => MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
NoChange
				Propellor Result -> Propellor Result -> Propellor Result
`concurrentSatisfy`
			t -> MVar [p] -> Propellor Result
startworkers (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) MVar [p]
q
	worker :: MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
r = do
		Maybe p
v <- IO (Maybe p) -> Propellor (Maybe p)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe p) -> Propellor (Maybe p))
-> IO (Maybe p) -> Propellor (Maybe p)
forall a b. (a -> b) -> a -> b
$ MVar [p] -> ([p] -> IO ([p], Maybe p)) -> IO (Maybe p)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [p]
q (([p] -> IO ([p], Maybe p)) -> IO (Maybe p))
-> ([p] -> IO ([p], Maybe p)) -> IO (Maybe p)
forall a b. (a -> b) -> a -> b
$ \[p]
v -> case [p]
v of
			[] -> ([p], Maybe p) -> IO ([p], Maybe p)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe p
forall a. Maybe a
Nothing)
			(p
p:[p]
rest) -> ([p], Maybe p) -> IO ([p], Maybe p)
forall (m :: * -> *) a. Monad m => a -> m a
return ([p]
rest, p -> Maybe p
forall a. a -> Maybe a
Just p
p)
		case Maybe p
v of
			Maybe p
Nothing -> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
			Just p
p -> do
				Desc
hn <- (Host -> Desc) -> Propellor Desc
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> Desc
hostName
				Result
r' <- case p -> Maybe (Propellor Result)
forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy p
p of
					Maybe (Propellor Result)
Nothing -> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
					Just Propellor Result
a -> Desc -> Desc -> Propellor Result -> Propellor Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
Desc -> Desc -> m r -> m r
actionMessageOn Desc
hn (p -> Desc
forall p. IsProp p => p -> Desc
getDesc p
p) Propellor Result
a
				MVar [p] -> Result -> Propellor Result
worker MVar [p]
q (Result
r Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
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 :: Int -> Propellor a -> Propellor a
withCapabilities Int
n Propellor a
a = Propellor Int
-> (Int -> Propellor ()) -> (Int -> Propellor a) -> Propellor a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket Propellor Int
setup Int -> Propellor ()
cleanup (Propellor a -> Int -> Propellor a
forall a b. a -> b -> a
const Propellor a
a)
  where
	setup :: Propellor Int
setup = do
		Int
np <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
		let n' :: Int
n' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
np
		Int
c <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumCapabilities
		Bool -> Propellor () -> Propellor ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
c) (Propellor () -> Propellor ()) -> Propellor () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ 
			IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n'
		Int -> Propellor Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
	cleanup :: Int -> Propellor ()
cleanup = IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> (Int -> IO ()) -> Int -> Propellor ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
setNumCapabilities

-- | Running Propellor actions concurrently.
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy Propellor Result
a1 Propellor Result
a2 = do
	Host
h <- Propellor Host
forall r (m :: * -> *). MonadReader r m => m r
ask
	((Result
r1, [EndAction]
w1), (Result
r2, [EndAction]
w2)) <- IO ((Result, [EndAction]), (Result, [EndAction]))
-> Propellor ((Result, [EndAction]), (Result, [EndAction]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((Result, [EndAction]), (Result, [EndAction]))
 -> Propellor ((Result, [EndAction]), (Result, [EndAction])))
-> IO ((Result, [EndAction]), (Result, [EndAction]))
-> Propellor ((Result, [EndAction]), (Result, [EndAction]))
forall a b. (a -> b) -> a -> b
$
		Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a1 Host
h IO (Result, [EndAction])
-> IO (Result, [EndAction])
-> IO ((Result, [EndAction]), (Result, [EndAction]))
forall a b. IO a -> IO b -> IO (a, b)
`A.concurrently` Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a2 Host
h
	[EndAction] -> Propellor ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([EndAction]
w1 [EndAction] -> [EndAction] -> [EndAction]
forall a. Semigroup a => a -> a -> a
<> [EndAction]
w2)
	Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
r1 Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
r2)
  where
	runp :: Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a Host
h = RWST Host [EndAction] () IO Result
-> Host -> () -> IO (Result, [EndAction])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (Propellor Result -> RWST Host [EndAction] () IO Result
forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost (Propellor Result -> Propellor Result
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor Propellor Result
a)) Host
h ()