From 47c7cd08324d62e5660bab77bafc80c5ddb54655 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Oct 2015 14:49:08 -0400 Subject: simplift --- src/Propellor/Engine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') 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) -- cgit v1.2.3 From e9cac11ad3df54208b4a41d945ac9a333d21bb07 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Oct 2015 15:17:40 -0400 Subject: Added Propellor.Property.Concurrent for concurrent properties. Note that no output multiplexing is currently done. --- debian/changelog | 7 +++ propellor.cabal | 1 + src/Propellor/Property/Concurrent.hs | 106 +++++++++++++++++++++++++++++++++++ src/Propellor/Property/List.hs | 1 + 4 files changed, 115 insertions(+) create mode 100644 src/Propellor/Property/Concurrent.hs (limited to 'src') diff --git a/debian/changelog b/debian/changelog index 7271fef5..feddb128 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (2.12.1) UNRELEASED; urgency=medium + + * Added Propellor.Property.Concurrent for concurrent properties. + (Note that no output multiplexing is currently done.) + + -- Joey Hess 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..c672da3a 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -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/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs new file mode 100644 index 00000000..95fd9fc5 --- /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 (Property x), IsProp (Property y), Combines (Property x) (Property y), IsProp (Property (CInfo x y))) + => Property x + -> Property y + -> CombinedType (Property x) (Property y) +concurrently p1 p2 = (combineWith 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/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 -- cgit v1.2.3 From 2410a8f1d6c850142181d724f4abd706a82b9593 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Oct 2015 16:43:26 -0400 Subject: improve RevertableProperty combining * 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 addional parameter to control how revert actions are combined (API change). --- debian/changelog | 9 ++- propellor.cabal | 2 +- src/Propellor/Property.hs | 69 ++++++++++++-------- src/Propellor/Property/Concurrent.hs | 10 +-- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/DnsSec.hs | 4 +- src/Propellor/Property/SiteSpecific/JoeySites.hs | 2 +- src/Propellor/Types.hs | 81 ++++++++++++------------ 8 files changed, 103 insertions(+), 76 deletions(-) (limited to 'src') diff --git a/debian/changelog b/debian/changelog index feddb128..7155a2ac 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,14 @@ -propellor (2.12.1) UNRELEASED; urgency=medium +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). -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/propellor.cabal b/propellor.cabal index c672da3a..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 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 index 95fd9fc5..c57f5228 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -21,11 +21,11 @@ import Control.Monad.RWS.Strict -- | Ensures two properties concurrently. concurrently - :: (IsProp (Property x), IsProp (Property y), Combines (Property x) (Property y), IsProp (Property (CInfo x y))) - => Property x - -> Property y - -> CombinedType (Property x) (Property y) -concurrently p1 p2 = (combineWith go p1 p2) + :: (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 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/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..5f0e0561 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 setup1 teardown1) (RevertableProperty setup2 teardown2) = + RevertableProperty + (combineWith sf tf setup1 setup2) + (combineWith tf sf teardown1 teardown2) 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 -- cgit v1.2.3 From 3c285d772a42a0bc4fef3a7255d26dc3e8488032 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Oct 2015 17:59:54 -0400 Subject: propellor spin --- src/Propellor/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 5f0e0561..06f0935d 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -262,10 +262,10 @@ instance Combines (Property NoInfo) (Property NoInfo) where SProperty d1 (f a1 a2) (y : cs1) instance Combines RevertableProperty RevertableProperty where - combineWith sf tf (RevertableProperty setup1 teardown1) (RevertableProperty setup2 teardown2) = + combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = RevertableProperty - (combineWith sf tf setup1 setup2) - (combineWith tf sf teardown1 teardown2) + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) instance Combines RevertableProperty (Property HasInfo) where combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y -- cgit v1.2.3 From 94d859a6cf094ed3bbdb268fca52c105f68803bd Mon Sep 17 00:00:00 2001 From: Per Olofsson Date: Mon, 26 Oct 2015 14:01:23 +0100 Subject: Add File.isCopyOf Signed-off-by: Per Olofsson --- src/Propellor/Property/File.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'src') 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 -- cgit v1.2.3