summaryrefslogtreecommitdiff
path: root/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-04-18 04:48:49 -0400
committerJoey Hess2014-04-18 04:48:49 -0400
commit5f6c3ad56490a8c3063f8daa1cd8b0a302b63ddd (patch)
treea05856a744c7ce6a6be69db327e5b8afec013257 /Propellor
parent4e4fb9ab7ca13f5148c6d4b08f53f518429530a8 (diff)
All Property combinators now combine together their Attr settings.
So Attr settings can be made inside a propertyList, for example.
Diffstat (limited to 'Propellor')
-rw-r--r--Propellor/Attr.hs4
-rw-r--r--Propellor/Engine.hs2
-rw-r--r--Propellor/Property.hs79
-rw-r--r--Propellor/Property/Apt.hs4
-rw-r--r--Propellor/Property/Cmd.hs1
-rw-r--r--Propellor/Property/Scheduled.hs4
-rw-r--r--Propellor/Types.hs18
-rw-r--r--Propellor/Types/Attr.hs2
8 files changed, 64 insertions, 50 deletions
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index d4fb25d2..03c882cc 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 c697d853..55ce7f77 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 aa419069..24494654 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 2115dc50..9234cbbf 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 5b7494ee..bcd08246 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 0e639129..f2911e50 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 01be9a5a..42401d12 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 1ff58148..00611775 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