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 qualified Data.Map as M
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
|
|
||||||
pureAttrProperty :: Desc -> (Attr -> Attr) -> Property
|
pureAttrProperty :: Desc -> SetAttr -> Property
|
||||||
pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
|
pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
|
||||||
|
|
||||||
hostname :: HostName -> Property
|
hostname :: HostName -> Property
|
||||||
|
@ -35,7 +35,7 @@ cnameFor domain mkp =
|
||||||
let p = mkp domain
|
let p = mkp domain
|
||||||
in p { propertyAttr = propertyAttr p . addCName 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) }
|
addCName domain d = d { _cnames = S.insert domain (_cnames d) }
|
||||||
|
|
||||||
sshPubKey :: String -> Property
|
sshPubKey :: String -> Property
|
||||||
|
|
|
@ -18,7 +18,7 @@ runPropellor attr a = runReaderT (runWithAttr a) attr
|
||||||
mainProperties :: Attr -> [Property] -> IO ()
|
mainProperties :: Attr -> [Property] -> IO ()
|
||||||
mainProperties attr ps = do
|
mainProperties attr ps = do
|
||||||
r <- runPropellor attr $
|
r <- runPropellor attr $
|
||||||
ensureProperties [property "overall" $ ensureProperties ps]
|
ensureProperties [Property "overall" (ensureProperties ps) id]
|
||||||
setTitle "propellor: done"
|
setTitle "propellor: done"
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
case r of
|
case r of
|
||||||
|
|
|
@ -5,6 +5,7 @@ module Propellor.Property where
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
|
import Data.List
|
||||||
import Control.Monad.IfElse
|
import Control.Monad.IfElse
|
||||||
import "mtl" Control.Monad.Reader
|
import "mtl" Control.Monad.Reader
|
||||||
|
|
||||||
|
@ -15,23 +16,21 @@ import Propellor.Engine
|
||||||
import Utility.Monad
|
import Utility.Monad
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
makeChange :: IO () -> Propellor Result
|
-- Constructs a Property.
|
||||||
makeChange a = liftIO a >> return MadeChange
|
property :: Desc -> Propellor Result -> Property
|
||||||
|
property d s = Property d s id
|
||||||
noChange :: Propellor Result
|
|
||||||
noChange = return NoChange
|
|
||||||
|
|
||||||
-- | Combines a list of properties, resulting in a single property
|
-- | Combines a list of properties, resulting in a single property
|
||||||
-- that when run will run each property in the list in turn,
|
-- 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
|
-- and print out the description of each as it's run. Does not stop
|
||||||
-- on failure; does propigate overall success/failure.
|
-- on failure; does propigate overall success/failure.
|
||||||
propertyList :: Desc -> [Property] -> Property
|
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
|
-- | Combines a list of properties, resulting in one property that
|
||||||
-- ensures each in turn, stopping on failure.
|
-- ensures each in turn, stopping on failure.
|
||||||
combineProperties :: Desc -> [Property] -> Property
|
combineProperties :: Desc -> [Property] -> Property
|
||||||
combineProperties desc ps = property desc $ go ps NoChange
|
combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
|
||||||
where
|
where
|
||||||
go [] rs = return rs
|
go [] rs = return rs
|
||||||
go (l:ls) rs = do
|
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.
|
-- that ensures the first, and if the first succeeds, ensures the second.
|
||||||
-- The property uses the description of the first property.
|
-- The property uses the description of the first property.
|
||||||
before :: Property -> Property -> Property
|
before :: Property -> Property -> Property
|
||||||
p1 `before` p2 = property (propertyDesc p1) $ do
|
p1 `before` p2 = p2 `requires` p1
|
||||||
r <- ensureProperty p1
|
`describe` (propertyDesc p1)
|
||||||
case r of
|
|
||||||
FailedChange -> return FailedChange
|
|
||||||
_ -> ensureProperty p2
|
|
||||||
|
|
||||||
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
|
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
|
||||||
-- file to indicate whether it has run before.
|
-- file to indicate whether it has run before.
|
||||||
|
@ -57,13 +53,13 @@ flagFile :: Property -> FilePath -> Property
|
||||||
flagFile p = flagFile' p . return
|
flagFile p = flagFile' p . return
|
||||||
|
|
||||||
flagFile' :: Property -> IO FilePath -> Property
|
flagFile' :: Property -> IO FilePath -> Property
|
||||||
flagFile' p getflagfile = property (propertyDesc p) $ do
|
flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
|
||||||
flagfile <- liftIO getflagfile
|
flagfile <- liftIO getflagfile
|
||||||
go flagfile =<< liftIO (doesFileExist flagfile)
|
go satisfy flagfile =<< liftIO (doesFileExist flagfile)
|
||||||
where
|
where
|
||||||
go _ True = return NoChange
|
go _ _ True = return NoChange
|
||||||
go flagfile False = do
|
go satisfy flagfile False = do
|
||||||
r <- ensureProperty p
|
r <- satisfy
|
||||||
when (r == MadeChange) $ liftIO $
|
when (r == MadeChange) $ liftIO $
|
||||||
unlessM (doesFileExist flagfile) $ do
|
unlessM (doesFileExist flagfile) $ do
|
||||||
createDirectoryIfMissing True (takeDirectory flagfile)
|
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
|
--- | Whenever a change has to be made for a Property, causes a hook
|
||||||
-- Property to also be run, but not otherwise.
|
-- Property to also be run, but not otherwise.
|
||||||
onChange :: Property -> Property -> Property
|
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
|
r <- ensureProperty p
|
||||||
case r of
|
case r of
|
||||||
MadeChange -> do
|
MadeChange -> do
|
||||||
|
@ -85,10 +83,10 @@ p `onChange` hook = property (propertyDesc p) $ do
|
||||||
(==>) = flip describe
|
(==>) = flip describe
|
||||||
infixl 1 ==>
|
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 :: IO Bool -> Property -> Property
|
||||||
check c p = property (propertyDesc p) $ ifM (liftIO c)
|
check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
|
||||||
( ensureProperty p
|
( satisfy
|
||||||
, return NoChange
|
, 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
|
-- to be made as it is to just idempotently assure the property is
|
||||||
-- satisfied. For example, chmodding a file.
|
-- satisfied. For example, chmodding a file.
|
||||||
trivial :: Property -> Property
|
trivial :: Property -> Property
|
||||||
trivial p = property (propertyDesc p) $ do
|
trivial p = adjustProperty p $ \satisfy -> do
|
||||||
r <- ensureProperty p
|
r <- satisfy
|
||||||
if r == MadeChange
|
if r == MadeChange
|
||||||
then return NoChange
|
then return NoChange
|
||||||
else return r
|
else return r
|
||||||
|
@ -133,16 +131,33 @@ host hn = Host [] (\_ -> newAttr hn)
|
||||||
|
|
||||||
-- | Adds a property to a Host
|
-- | Adds a property to a Host
|
||||||
--
|
--
|
||||||
-- Can add Properties, RevertableProperties, and AttrProperties
|
-- Can add Properties and RevertableProperties
|
||||||
(&) :: IsProp p => Host -> p -> Host
|
(&) :: 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 &
|
infixl 1 &
|
||||||
|
|
||||||
-- | Adds a property to the Host in reverted form.
|
-- | Adds a property to the Host in reverted form.
|
||||||
(!) :: Host -> RevertableProperty -> Host
|
(!) :: 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
|
where
|
||||||
q = revert p
|
q = revert p
|
||||||
|
|
||||||
infixl 1 !
|
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.
|
-- | Package installation may fail becuse the archive has changed.
|
||||||
-- Run an update in that case and retry.
|
-- Run an update in that case and retry.
|
||||||
robustly :: Property -> Property
|
robustly :: Property -> Property
|
||||||
robustly p = property (propertyDesc p) $ do
|
robustly p = adjustProperty p $ \satisfy -> do
|
||||||
r <- ensureProperty p
|
r <- satisfy
|
||||||
if r == FailedChange
|
if r == FailedChange
|
||||||
then ensureProperty $ p `requires` update
|
then ensureProperty $ p `requires` update
|
||||||
else return r
|
else return r
|
||||||
|
|
|
@ -12,6 +12,7 @@ import Data.List
|
||||||
import "mtl" Control.Monad.Reader
|
import "mtl" Control.Monad.Reader
|
||||||
|
|
||||||
import Propellor.Types
|
import Propellor.Types
|
||||||
|
import Propellor.Property
|
||||||
import Utility.Monad
|
import Utility.Monad
|
||||||
import Utility.SafeCommand
|
import Utility.SafeCommand
|
||||||
import Utility.Env
|
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
|
-- This uses the description of the Property to keep track of when it was
|
||||||
-- last run.
|
-- last run.
|
||||||
period :: Property -> Recurrance -> Property
|
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)
|
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
|
||||||
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
|
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
|
||||||
t <- liftIO localNow
|
t <- liftIO localNow
|
||||||
if Just t >= nexttime
|
if Just t >= nexttime
|
||||||
then do
|
then do
|
||||||
r <- ensureProperty prop
|
r <- satisfy
|
||||||
liftIO $ setLastChecked t (propertyDesc prop)
|
liftIO $ setLastChecked t (propertyDesc prop)
|
||||||
return r
|
return r
|
||||||
else noChange
|
else noChange
|
||||||
|
|
|
@ -8,12 +8,11 @@ module Propellor.Types
|
||||||
, HostName
|
, HostName
|
||||||
, Propellor(..)
|
, Propellor(..)
|
||||||
, Property(..)
|
, Property(..)
|
||||||
, property
|
|
||||||
, RevertableProperty(..)
|
, RevertableProperty(..)
|
||||||
, IsProp
|
, IsProp
|
||||||
, describe
|
, describe
|
||||||
, toProp
|
, toProp
|
||||||
, getAttr
|
, setAttr
|
||||||
, requires
|
, requires
|
||||||
, Desc
|
, Desc
|
||||||
, Result(..)
|
, Result(..)
|
||||||
|
@ -34,7 +33,7 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO
|
||||||
import Propellor.Types.Attr
|
import Propellor.Types.Attr
|
||||||
import Propellor.Types.OS
|
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
|
-- | Propellor's monad provides read-only access to attributes of the
|
||||||
-- system.
|
-- system.
|
||||||
|
@ -55,13 +54,10 @@ data Property = Property
|
||||||
{ propertyDesc :: Desc
|
{ propertyDesc :: Desc
|
||||||
, propertySatisfy :: Propellor Result
|
, propertySatisfy :: Propellor Result
|
||||||
-- ^ must be idempotent; may run repeatedly
|
-- ^ must be idempotent; may run repeatedly
|
||||||
, propertyAttr :: Attr -> Attr
|
, propertyAttr :: SetAttr
|
||||||
-- ^ a property can affect the overall Attr
|
-- ^ 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.
|
-- | A property that can be reverted.
|
||||||
data RevertableProperty = RevertableProperty Property Property
|
data RevertableProperty = RevertableProperty Property Property
|
||||||
|
|
||||||
|
@ -72,12 +68,12 @@ class IsProp p where
|
||||||
-- | Indicates that the first property can only be satisfied
|
-- | Indicates that the first property can only be satisfied
|
||||||
-- once the second one is.
|
-- once the second one is.
|
||||||
requires :: p -> Property -> p
|
requires :: p -> Property -> p
|
||||||
getAttr :: p -> (Attr -> Attr)
|
setAttr :: p -> SetAttr
|
||||||
|
|
||||||
instance IsProp Property where
|
instance IsProp Property where
|
||||||
describe p d = p { propertyDesc = d }
|
describe p d = p { propertyDesc = d }
|
||||||
toProp p = p
|
toProp p = p
|
||||||
getAttr = propertyAttr
|
setAttr = propertyAttr
|
||||||
x `requires` y = Property (propertyDesc x) satisfy attr
|
x `requires` y = Property (propertyDesc x) satisfy attr
|
||||||
where
|
where
|
||||||
attr = propertyAttr x . propertyAttr y
|
attr = propertyAttr x . propertyAttr y
|
||||||
|
@ -95,8 +91,8 @@ instance IsProp RevertableProperty where
|
||||||
toProp (RevertableProperty p1 _) = p1
|
toProp (RevertableProperty p1 _) = p1
|
||||||
(RevertableProperty p1 p2) `requires` y =
|
(RevertableProperty p1 p2) `requires` y =
|
||||||
RevertableProperty (p1 `requires` y) p2
|
RevertableProperty (p1 `requires` y) p2
|
||||||
-- | Gets the Attr of the currently active side.
|
-- | Return the SetAttr of the currently active side.
|
||||||
getAttr (RevertableProperty p1 _p2) = getAttr p1
|
setAttr (RevertableProperty p1 _p2) = setAttr p1
|
||||||
|
|
||||||
type Desc = String
|
type Desc = String
|
||||||
|
|
||||||
|
|
|
@ -42,3 +42,5 @@ newAttr hn = Attr hn S.empty Nothing Nothing Nothing []
|
||||||
|
|
||||||
type HostName = String
|
type HostName = String
|
||||||
type Domain = 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
|
* There is no way for a property of a docker container to require
|
||||||
some property be met outside the container. For example, some servers
|
some property be met outside the container. For example, some servers
|
||||||
need ntp installed for a good date source.
|
need ntp installed for a good date source.
|
||||||
* Attributes can only be set in the top level property list for a Host.
|
* Docking a container in a host should add to the host any cnames that
|
||||||
If an attribute is set inside a propertyList, it won't propigate out.
|
are assigned to the container.
|
||||||
Fix this. Probably the fix involves combining AttrProperty into Property.
|
|
||||||
Then propertyList can gather the attributes from its list.
|
|
||||||
|
|
|
@ -1,7 +1,10 @@
|
||||||
propellor (0.4.0) UNRELEASED; urgency=medium
|
propellor (0.4.0) UNRELEASED; urgency=medium
|
||||||
|
|
||||||
* Constructor of Property has changed (use property function instead).
|
* 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
|
-- Joey Hess <joeyh@debian.org> Thu, 17 Apr 2014 21:00:43 -0400
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue