Merge branch 'joeyconfig'

6 files changed, 133 insertions, 4 deletions

diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
new file mode 100644
index 00000000..c57f5228
--- /dev/null
+++ b/src/Propellor/Property/Concurrent.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | Note that this module does not yet arrange for any output multiplexing,
+-- so the output of 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 ()
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 6646582b..4c2f787f 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -164,7 +164,7 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
 		`onChange` Service.reloaded "bind9"
 
 	cleanup = cleanupPrimary zonefile domain
-		`onChange` toProp (revert (zoneSigned domain zonefile))
+		`onChange` revert (zoneSigned domain zonefile)
 		`onChange` Service.reloaded "bind9"
 
 	-- Include the public keys into the zone file.
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index 7d1414d4..c0aa1302 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -41,11 +41,11 @@ zoneSigned :: Domain -> FilePath -> RevertableProperty
 zoneSigned domain zonefile = setup <!> cleanup
   where
 	setup = check needupdate (forceZoneSigned domain zonefile)
-		`requires` toProp (keysInstalled domain)
+		`requires` keysInstalled domain
 	
 	cleanup = File.notPresent (signedZoneFile zonefile)
 		`before` File.notPresent dssetfile
-		`before` toProp (revert (keysInstalled domain))
+		`before` revert (keysInstalled domain)
 	
 	dssetfile = dir </> "-" ++ domain ++ "."
 	dir = takeDirectory zonefile
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 3476bad0..e29eceb8 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -5,6 +5,7 @@ import Utility.FileMode
 
 import System.Posix.Files
 import System.PosixCompat.Types
+import System.Exit
 
 type Line = String
 
@@ -134,6 +135,27 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
 			else makeChange updateLink
 	updateLink = createSymbolicLink target `viaStableTmp` link
 
+-- | Ensures that a file is a copy of another (regular) file.
+isCopyOf :: FilePath -> FilePath -> Property NoInfo
+f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
+  where
+	desc = f ++ " is copy of " ++ f'
+	go (Right stat) = if isRegularFile stat
+		then gocmp =<< (liftIO $ cmp)
+		else warningMessage (f' ++ " is not a regular file") >>
+			return FailedChange
+	go (Left e) = warningMessage (show e) >> return FailedChange
+
+	cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f']
+	gocmp ExitSuccess = noChange
+	gocmp (ExitFailure 1) = doit
+	gocmp _ = warningMessage "cmp failed" >> return FailedChange
+
+	doit = makeChange $ copy f' `viaStableTmp` f
+	copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed"
+	runcp src dest = boolSystem "cp"
+		[Param "--preserve=all", Param "--", File src, File dest]
+
 -- | Ensures that a file/dir has the specified owner and group.
 ownerGroup :: FilePath -> User -> Group -> Property NoInfo
 ownerGroup f (User owner) (Group group) = property (f ++ " owner " ++ og) $ do
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 41451ef5..86fdfbf1 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -5,6 +5,7 @@ module Propellor.Property.List (
 	props,
 	PropertyList(..),
 	PropertyListType,
+	PropList(..),
 ) where
 
 import Propellor.Types
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 70d5884f..92903e9a 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -924,7 +924,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
 userDirHtml :: Property HasInfo
 userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
 	`onChange` Apache.reloaded
-	`requires` (toProp $ Apache.modEnabled "userdir")
+	`requires` Apache.modEnabled "userdir"
   where
 	munge = replace "public_html" "html"
 	conf = "/etc/apache2/mods-available/userdir.conf"