summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Concurrent.hs106
-rw-r--r--src/Propellor/Property/Dns.hs2
-rw-r--r--src/Propellor/Property/DnsSec.hs4
-rw-r--r--src/Propellor/Property/File.hs22
-rw-r--r--src/Propellor/Property/List.hs1
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs2
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"