summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog15
-rw-r--r--propellor.cabal3
-rw-r--r--src/Propellor/Engine.hs2
-rw-r--r--src/Propellor/Property.hs69
-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
-rw-r--r--src/Propellor/Types.hs81
11 files changed, 236 insertions, 71 deletions
diff --git a/debian/changelog b/debian/changelog
index f4be6655..c5eef2c9 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,18 @@
+propellor (2.13.0) UNRELEASED; urgency=medium
+
+ * Added Propellor.Property.Concurrent for concurrent properties.
+ (Note that no output multiplexing is currently done.)
+ * Various property combinators that combined a RevertableProperty
+ with a non-revertable property used to yield a RevertableProperty.
+ This was a bug, because the combined property could not be fully
+ reverted in many cases. Fixed by making the combined property
+ instead be a Property HasInfo.
+ * combineWith now takes an additional parameter to control how revert
+ actions are combined (API change).
+ * Add File.isCopyOf. Thanks, Per Olofsson.
+
+ -- Joey Hess <id@joeyh.name> Sat, 24 Oct 2015 15:16:45 -0400
+
propellor (2.12.0) unstable; urgency=medium
* The DiskImage module can now make bootable images using grub.
diff --git a/propellor.cabal b/propellor.cabal
index 8a466a28..7a9d2b5d 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.12.0
+Version: 2.13.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -76,6 +76,7 @@ Library
Propellor.Property.Apache
Propellor.Property.Apt
Propellor.Property.Cmd
+ Propellor.Property.Concurrent
Propellor.Property.Conductor
Propellor.Property.Hostname
Propellor.Property.Chroot
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 8c1d09c6..a811724a 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -55,7 +55,7 @@ mainProperties host = do
-- are then also run.
runPropellor :: Host -> Propellor Result -> IO Result
runPropellor host a = do
- (res, _s, endactions) <- runRWST (runWithHost a) host ()
+ (res, endactions) <- evalRWST (runWithHost a) host ()
endres <- mapM (runEndAction host res) endactions
return $ mconcat (res:endres)
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 95805054..d80d9c1f 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -66,30 +66,43 @@ flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
-- | Indicates that the first property depends on the second,
-- so before the first is ensured, the second must be ensured.
+--
+-- The combined property uses the description of the first property.
requires :: Combines x y => x -> y -> CombinedType x y
-requires = (<<>>)
+requires = combineWith
+ -- Run action of y, then x
+ (flip (<>))
+ -- When reverting, run in reverse order.
+ (<>)
-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
--
-- The combined property uses the description of the first property.
-before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
-before x y = (y `requires` x) `describe` getDesc x
+before :: Combines x y => x -> y -> CombinedType x y
+before = combineWith
+ -- Run action of x, then y
+ (<>)
+ -- When reverting, run in reverse order.
+ (flip (<>))
-- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange
- :: (Combines (Property x) (Property y))
- => Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-onChange = combineWith $ \p hook -> do
- r <- p
- case r of
- MadeChange -> do
- r' <- hook
- return $ r <> r'
- _ -> return r
+ :: (Combines x y)
+ => x
+ -> y
+ -> CombinedType x y
+onChange = combineWith combiner revertcombiner
+ where
+ combiner p hook = do
+ r <- p
+ case r of
+ MadeChange -> do
+ r' <- hook
+ return $ r <> r'
+ _ -> return r
+ revertcombiner = (<>)
-- | Same as `onChange` except that if property y fails, a flag file
-- is generated. On next run, if the flag file is present, property y
@@ -99,14 +112,14 @@ onChange = combineWith $ \p hook -> do
-- `FailedChange`. But if this property is applied again, it returns
-- `NoChange`. This behavior can cause trouble...
onChangeFlagOnFail
- :: (Combines (Property x) (Property y))
+ :: (Combines x y)
=> FilePath
- -> Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-onChangeFlagOnFail flagfile = combineWith go
+ -> x
+ -> y
+ -> CombinedType x y
+onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
where
- go s1 s2 = do
+ combiner s1 s2 = do
r1 <- s1
case r1 of
MadeChange -> flagFailed s2
@@ -114,6 +127,7 @@ onChangeFlagOnFail flagfile = combineWith go
(flagFailed s2
, return r1
)
+ revertcombiner = (<>)
flagFailed s = do
r <- s
liftIO $ case r of
@@ -151,12 +165,15 @@ check c p = adjustPropertySatisfy p $ \satisfy ->
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
-fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)
-fallback = combineWith $ \a1 a2 -> do
- r <- a1
- if r == FailedChange
- then a2
- else return r
+fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
+fallback = combineWith combiner revertcombiner
+ where
+ combiner a1 a2 = do
+ r <- a1
+ if r == FailedChange
+ then a2
+ else return r
+ revertcombiner = (<>)
-- | Marks a Property as trivial. It can only return FailedChange or
-- NoChange.
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"
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 5904374e..06f0935d 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -27,7 +27,6 @@ module Propellor.Types
, IsProp(..)
, Combines(..)
, CombinedType
- , combineWith
, Propellor(..)
, LiftPropellor(..)
, EndAction(..)
@@ -160,6 +159,9 @@ propertySatisfy (SProperty _ a _) = a
instance Show (Property i) where
show p = "property " ++ show (propertyDesc p)
+instance Show RevertableProperty where
+ show (RevertableProperty p _) = "property " ++ show (propertyDesc p)
+
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
@@ -221,57 +223,58 @@ instance IsProp RevertableProperty where
-- types of properties.
type family CombinedType x y
type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
-type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty
-type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty
type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty
+-- When only one of the properties is revertable, the combined property is
+-- not fully revertable, so is not a RevertableProperty.
+type instance CombinedType RevertableProperty (Property NoInfo) = Property HasInfo
+type instance CombinedType RevertableProperty (Property HasInfo) = Property HasInfo
+type instance CombinedType (Property NoInfo) RevertableProperty = Property HasInfo
+type instance CombinedType (Property HasInfo) RevertableProperty = Property HasInfo
class Combines x y where
- -- | Combines two properties. The second property is ensured
- -- first, and only once it is successfully ensures will the first
- -- be ensured. The combined property will have the description of
- -- the first property.
- (<<>>) :: x -> y -> CombinedType x y
-
--- | Combines together two properties, yielding a property that
--- has the description and info of the first, and that has the second
--- property as a child. The two actions to satisfy the properties
--- are passed to a function that can combine them in arbitrary ways.
-combineWith
- :: (Combines (Property x) (Property y))
- => (Propellor Result -> Propellor Result -> Propellor Result)
- -> Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-combineWith f x y = adjustPropertySatisfy (x <<>> y) $ \_ ->
- f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)
+ -- | Combines together two properties, yielding a property that
+ -- has the description and info of the first, and that has the second
+ -- property as a child.
+ combineWith
+ :: (Propellor Result -> Propellor Result -> Propellor Result)
+ -- ^ How to combine the actions to satisfy the properties.
+ -> (Propellor Result -> Propellor Result -> Propellor Result)
+ -- ^ Used when combining revertable properties, to combine
+ -- their reversion actions.
+ -> x
+ -> y
+ -> CombinedType x y
instance Combines (Property HasInfo) (Property HasInfo) where
- (IProperty d1 a1 i1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (a2 <> a1) i1 (y : cs1)
+ combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (f a1 a2) i1 (y : cs1)
instance Combines (Property HasInfo) (Property NoInfo) where
- (IProperty d1 a1 i1 cs1) <<>> y@(SProperty _d2 a2 _cs2) =
- IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
+ combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+ IProperty d1 (f a1 a2) i1 (toIProperty y : cs1)
instance Combines (Property NoInfo) (Property HasInfo) where
- (SProperty d1 a1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)
+ combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1)
instance Combines (Property NoInfo) (Property NoInfo) where
- (SProperty d1 a1 cs1) <<>> y@(SProperty _d2 a2 _cs2) =
- SProperty d1 (a2 <> a1) (y : cs1)
+ combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
+ SProperty d1 (f a1 a2) (y : cs1)
+
+instance Combines RevertableProperty RevertableProperty where
+ combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
+ RevertableProperty
+ (combineWith sf tf s1 s2)
+ (combineWith tf sf t1 t2)
instance Combines RevertableProperty (Property HasInfo) where
- (RevertableProperty p1 p2) <<>> y =
- RevertableProperty (p1 <<>> y) p2
+ combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
instance Combines RevertableProperty (Property NoInfo) where
- (RevertableProperty p1 p2) <<>> y =
- RevertableProperty (p1 <<>> toIProperty y) p2
+ combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
-instance Combines RevertableProperty RevertableProperty where
- (RevertableProperty x1 x2) <<>> (RevertableProperty y1 y2) =
- RevertableProperty
- (x1 <<>> y1)
- -- when reverting, run actions in reverse order
- (y2 <<>> x2)
+instance Combines (Property HasInfo) RevertableProperty where
+ combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
+
+instance Combines (Property NoInfo) RevertableProperty where
+ combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y