All Property combinators now combine together their Attr settings.
So Attr settings can be made inside a propertyList, for example.
This commit is contained in:
parent
4e4fb9ab7c
commit
5f6c3ad564
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,7 +69,9 @@ 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
|
||||
p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
|
||||
where
|
||||
satisfy = do
|
||||
r <- ensureProperty p
|
||||
case r of
|
||||
MadeChange -> do
|
||||
|
@ -85,10 +83,10 @@ p `onChange` hook = property (propertyDesc p) $ do
|
|||
(==>) = 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -42,3 +42,5 @@ newAttr hn = Attr hn S.empty Nothing Nothing Nothing []
|
|||
|
||||
type HostName = String
|
||||
type Domain = String
|
||||
|
||||
type SetAttr = Attr -> Attr
|
||||
|
|
6
TODO
6
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.
|
||||
|
|
|
@ -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 <joeyh@debian.org> Thu, 17 Apr 2014 21:00:43 -0400
|
||||
|
||||
|
|
Loading…
Reference in New Issue