From 5f6c3ad56490a8c3063f8daa1cd8b0a302b63ddd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Apr 2014 04:48:49 -0400 Subject: [PATCH] All Property combinators now combine together their Attr settings. So Attr settings can be made inside a propertyList, for example. --- Propellor/Attr.hs | 4 +- Propellor/Engine.hs | 2 +- Propellor/Property.hs | 79 ++++++++++++++++++++------------- Propellor/Property/Apt.hs | 4 +- Propellor/Property/Cmd.hs | 1 + Propellor/Property/Scheduled.hs | 4 +- Propellor/Types.hs | 18 +++----- Propellor/Types/Attr.hs | 2 + TODO | 6 +-- debian/changelog | 5 ++- 10 files changed, 70 insertions(+), 55 deletions(-) diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs index d4fb25d..03c882c 100644 --- a/Propellor/Attr.hs +++ b/Propellor/Attr.hs @@ -10,7 +10,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Control.Applicative -pureAttrProperty :: Desc -> (Attr -> Attr) -> Property +pureAttrProperty :: Desc -> SetAttr -> Property pureAttrProperty desc = Property ("has " ++ desc) (return NoChange) hostname :: HostName -> Property @@ -35,7 +35,7 @@ cnameFor domain mkp = let p = mkp domain in p { propertyAttr = propertyAttr p . addCName domain } -addCName :: HostName -> Attr -> Attr +addCName :: HostName -> SetAttr addCName domain d = d { _cnames = S.insert domain (_cnames d) } sshPubKey :: String -> Property diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index c697d85..55ce7f7 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -18,7 +18,7 @@ runPropellor attr a = runReaderT (runWithAttr a) attr mainProperties :: Attr -> [Property] -> IO () mainProperties attr ps = do r <- runPropellor attr $ - ensureProperties [property "overall" $ ensureProperties ps] + ensureProperties [Property "overall" (ensureProperties ps) id] setTitle "propellor: done" hFlush stdout case r of diff --git a/Propellor/Property.hs b/Propellor/Property.hs index aa41906..2449465 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -5,6 +5,7 @@ module Propellor.Property where import System.Directory import Control.Monad import Data.Monoid +import Data.List import Control.Monad.IfElse import "mtl" Control.Monad.Reader @@ -15,23 +16,21 @@ import Propellor.Engine import Utility.Monad import System.FilePath -makeChange :: IO () -> Propellor Result -makeChange a = liftIO a >> return MadeChange - -noChange :: Propellor Result -noChange = return NoChange +-- Constructs a Property. +property :: Desc -> Propellor Result -> Property +property d s = Property d s id -- | Combines a list of properties, resulting in a single property -- that when run will run each property in the list in turn, -- and print out the description of each as it's run. Does not stop -- on failure; does propigate overall success/failure. propertyList :: Desc -> [Property] -> Property -propertyList desc ps = property desc $ ensureProperties ps +propertyList desc ps = Property desc (ensureProperties ps) (combineSetAttrs ps) -- | Combines a list of properties, resulting in one property that -- ensures each in turn, stopping on failure. combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = property desc $ go ps NoChange +combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps) where go [] rs = return rs go (l:ls) rs = do @@ -44,11 +43,8 @@ combineProperties desc ps = property desc $ go ps NoChange -- that ensures the first, and if the first succeeds, ensures the second. -- The property uses the description of the first property. before :: Property -> Property -> Property -p1 `before` p2 = property (propertyDesc p1) $ do - r <- ensureProperty p1 - case r of - FailedChange -> return FailedChange - _ -> ensureProperty p2 +p1 `before` p2 = p2 `requires` p1 + `describe` (propertyDesc p1) -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. @@ -57,13 +53,13 @@ flagFile :: Property -> FilePath -> Property flagFile p = flagFile' p . return flagFile' :: Property -> IO FilePath -> Property -flagFile' p getflagfile = property (propertyDesc p) $ do +flagFile' p getflagfile = adjustProperty p $ \satisfy -> do flagfile <- liftIO getflagfile - go flagfile =<< liftIO (doesFileExist flagfile) + go satisfy flagfile =<< liftIO (doesFileExist flagfile) where - go _ True = return NoChange - go flagfile False = do - r <- ensureProperty p + go _ _ True = return NoChange + go satisfy flagfile False = do + r <- satisfy when (r == MadeChange) $ liftIO $ unlessM (doesFileExist flagfile) $ do createDirectoryIfMissing True (takeDirectory flagfile) @@ -73,22 +69,24 @@ flagFile' p getflagfile = property (propertyDesc p) $ do --- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property -p `onChange` hook = property (propertyDesc p) $ do - r <- ensureProperty p - case r of - MadeChange -> do - r' <- ensureProperty hook - return $ r <> r' - _ -> return r +p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook) + where + satisfy = do + r <- ensureProperty p + case r of + MadeChange -> do + r' <- ensureProperty hook + return $ r <> r' + _ -> return r (==>) :: Desc -> Property -> Property (==>) = flip describe infixl 1 ==> --- | Makes a Property only be performed when a test succeeds. +-- | Makes a Property only need to do anything when a test succeeds. check :: IO Bool -> Property -> Property -check c p = property (propertyDesc p) $ ifM (liftIO c) - ( ensureProperty p +check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) + ( satisfy , return NoChange ) @@ -99,8 +97,8 @@ check c p = property (propertyDesc p) $ ifM (liftIO c) -- to be made as it is to just idempotently assure the property is -- satisfied. For example, chmodding a file. trivial :: Property -> Property -trivial p = property (propertyDesc p) $ do - r <- ensureProperty p +trivial p = adjustProperty p $ \satisfy -> do + r <- satisfy if r == MadeChange then return NoChange else return r @@ -133,16 +131,33 @@ host hn = Host [] (\_ -> newAttr hn) -- | Adds a property to a Host -- --- Can add Properties, RevertableProperties, and AttrProperties +-- Can add Properties and RevertableProperties (&) :: IsProp p => Host -> p -> Host -(Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as) +(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as) infixl 1 & -- | Adds a property to the Host in reverted form. (!) :: Host -> RevertableProperty -> Host -(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as) +(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as) where q = revert p infixl 1 ! + +-- Changes the action that is performed to satisfy a property. +adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property +adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } + +-- Combines the Attr settings of two properties. +combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr +combineSetAttr p q = setAttr p . setAttr q + +combineSetAttrs :: IsProp p => [p] -> SetAttr +combineSetAttrs = foldl' (.) id . map setAttr + +makeChange :: IO () -> Propellor Result +makeChange a = liftIO a >> return MadeChange + +noChange :: Propellor Result +noChange = return NoChange diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs index 2115dc5..9234cbb 100644 --- a/Propellor/Property/Apt.hs +++ b/Propellor/Property/Apt.hs @@ -157,8 +157,8 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. robustly :: Property -> Property -robustly p = property (propertyDesc p) $ do - r <- ensureProperty p +robustly p = adjustProperty p $ \satisfy -> do + r <- satisfy if r == FailedChange then ensureProperty $ p `requires` update else return r diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs index 5b7494e..bcd0824 100644 --- a/Propellor/Property/Cmd.hs +++ b/Propellor/Property/Cmd.hs @@ -12,6 +12,7 @@ import Data.List import "mtl" Control.Monad.Reader import Propellor.Types +import Propellor.Property import Utility.Monad import Utility.SafeCommand import Utility.Env diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 0e63912..f2911e5 100644 --- a/Propellor/Property/Scheduled.hs +++ b/Propellor/Property/Scheduled.hs @@ -19,13 +19,13 @@ import qualified Data.Map as M -- This uses the description of the Property to keep track of when it was -- last run. period :: Property -> Recurrance -> Property -period prop recurrance = property desc $ do +period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do lasttime <- liftIO $ getLastChecked (propertyDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do - r <- ensureProperty prop + r <- satisfy liftIO $ setLastChecked t (propertyDesc prop) return r else noChange diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 01be9a5..42401d1 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -8,12 +8,11 @@ module Propellor.Types , HostName , Propellor(..) , Property(..) - , property , RevertableProperty(..) , IsProp , describe , toProp - , getAttr + , setAttr , requires , Desc , Result(..) @@ -34,7 +33,7 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO import Propellor.Types.Attr import Propellor.Types.OS -data Host = Host [Property] (Attr -> Attr) +data Host = Host [Property] SetAttr -- | Propellor's monad provides read-only access to attributes of the -- system. @@ -55,13 +54,10 @@ data Property = Property { propertyDesc :: Desc , propertySatisfy :: Propellor Result -- ^ must be idempotent; may run repeatedly - , propertyAttr :: Attr -> Attr + , propertyAttr :: SetAttr -- ^ a property can affect the overall Attr } -property :: Desc -> Propellor Result -> Property -property d s = Property d s id - -- | A property that can be reverted. data RevertableProperty = RevertableProperty Property Property @@ -72,12 +68,12 @@ class IsProp p where -- | Indicates that the first property can only be satisfied -- once the second one is. requires :: p -> Property -> p - getAttr :: p -> (Attr -> Attr) + setAttr :: p -> SetAttr instance IsProp Property where describe p d = p { propertyDesc = d } toProp p = p - getAttr = propertyAttr + setAttr = propertyAttr x `requires` y = Property (propertyDesc x) satisfy attr where attr = propertyAttr x . propertyAttr y @@ -95,8 +91,8 @@ instance IsProp RevertableProperty where toProp (RevertableProperty p1 _) = p1 (RevertableProperty p1 p2) `requires` y = RevertableProperty (p1 `requires` y) p2 - -- | Gets the Attr of the currently active side. - getAttr (RevertableProperty p1 _p2) = getAttr p1 + -- | Return the SetAttr of the currently active side. + setAttr (RevertableProperty p1 _p2) = setAttr p1 type Desc = String diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs index 1ff5814..0061177 100644 --- a/Propellor/Types/Attr.hs +++ b/Propellor/Types/Attr.hs @@ -42,3 +42,5 @@ newAttr hn = Attr hn S.empty Nothing Nothing Nothing [] type HostName = String type Domain = String + +type SetAttr = Attr -> Attr diff --git a/TODO b/TODO index 93dcf0d..96324ad 100644 --- a/TODO +++ b/TODO @@ -15,7 +15,5 @@ * There is no way for a property of a docker container to require some property be met outside the container. For example, some servers need ntp installed for a good date source. -* Attributes can only be set in the top level property list for a Host. - If an attribute is set inside a propertyList, it won't propigate out. - Fix this. Probably the fix involves combining AttrProperty into Property. - Then propertyList can gather the attributes from its list. +* Docking a container in a host should add to the host any cnames that + are assigned to the container. diff --git a/debian/changelog b/debian/changelog index 3cef12d..ee7df1e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,10 @@ propellor (0.4.0) UNRELEASED; urgency=medium * Constructor of Property has changed (use property function instead). - * Run all cron jobs under chronic from moreutils to avoid unnecessary mails. + * All Property combinators now combine together their Attr settings. + So Attr settings can be made inside a propertyList, for example. + * Run all cron jobs under chronic from moreutils to avoid unnecessary + mails. -- Joey Hess Thu, 17 Apr 2014 21:00:43 -0400