summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Engine.hs9
-rw-r--r--src/Propellor/Info.hs12
-rw-r--r--src/Propellor/Types.hs155
3 files changed, 110 insertions, 66 deletions
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index ddc22305..552b910c 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -45,7 +45,7 @@ mainProperties host = do
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
where
- ps = hostProperties host
+ ps = map ignoreInfo $ hostProperties host
-- | Runs a Propellor action with the specified host.
--
@@ -66,13 +66,12 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
-- | For when code running in the Propellor monad needs to ensure a
-- Property.
--
--- Note that the Info of the Property is not propigated out, so it will
--- not be visible to propellor, unless you arrange for it to be propigated.
-ensureProperty :: Property -> Propellor Result
+-- This can only be used on a Property that has NoInfo.
+ensureProperty :: Property NoInfo -> Propellor Result
ensureProperty = catchPropellor . propertySatisfy
-- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property] -> Propellor Result
+ensureProperties :: [Property NoInfo] -> Propellor Result
ensureProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 6d85cb74..1d8e7ab2 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -12,13 +12,13 @@ import Data.Maybe
import Data.Monoid
import Control.Applicative
-pureInfoProperty :: Desc -> Info -> Property
+pureInfoProperty :: Desc -> Info -> Property HasInfo
pureInfoProperty desc i = mkProperty ("has " ++ desc) (return NoChange) i mempty
askInfo :: (Info -> Val a) -> Propellor (Maybe a)
askInfo f = asks (fromVal . f . hostInfo)
-os :: System -> Property
+os :: System -> Property HasInfo
os system = pureInfoProperty ("Operating " ++ show system) $
mempty { _os = Val system }
@@ -34,11 +34,11 @@ getOS = askInfo _os
-- When propellor --spin is used to deploy a host, it checks
-- if the host's IP Property matches the DNS. If the DNS is missing or
-- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property
+ipv4 :: String -> Property HasInfo
ipv4 = addDNS . Address . IPv4
-- | Indidate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property
+ipv6 :: String -> Property HasInfo
ipv6 = addDNS . Address . IPv6
-- | Indicates another name for the host in the DNS.
@@ -47,7 +47,7 @@ ipv6 = addDNS . Address . IPv6
-- to use their address, rather than using a CNAME. This avoids various
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property
+alias :: Domain -> Property HasInfo
alias d = pureInfoProperty ("alias " ++ d) $ mempty
{ _aliases = S.singleton d
-- A CNAME is added here, but the DNS setup code converts it to an
@@ -55,7 +55,7 @@ alias d = pureInfoProperty ("alias " ++ d) $ mempty
, _dns = S.singleton $ CNAME $ AbsDomain d
}
-addDNS :: Record -> Property
+addDNS :: Record -> Property HasInfo
addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
where
rdesc (CNAME d) = unwords ["alias", ddesc d]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index ba8b7b95..6d5b8134 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -2,24 +2,31 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Propellor.Types
( Host(..)
, Property(..)
+ , HasInfo
+ , NoInfo
+ , Desc
, mkProperty
, propertyDesc
, propertySatisfy
, propertyInfo
, propertyChildren
, RevertableProperty(..)
+ , mkRevertableProperty
+ , requires
, IsProp(..)
- , Desc
, Info(..)
, Propellor(..)
, EndAction(..)
, module Propellor.Types.OS
, module Propellor.Types.Dns
, module Propellor.Types.Result
+ , ignoreInfo
) where
import Data.Monoid
@@ -43,7 +50,7 @@ import qualified Propellor.Types.Dns as Dns
-- properties and their collected info.
data Host = Host
{ hostName :: HostName
- , hostProperties :: [Property]
+ , hostProperties :: [Property HasInfo]
, hostInfo :: Info
}
deriving (Show)
@@ -65,96 +72,134 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
-- properties. It's passed the combined Result of the entire Propellor run.
data EndAction = EndAction Desc (Result -> Propellor Result)
+type Desc = String
+
-- | The core data type of Propellor, this represents a property
-- that the system should have, and an action to ensure it has the
-- property.
-data Property = IProperty (GProperty HasInfo) | SProperty (GProperty NoInfo)
+data Property i where
+ IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
+ SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
+
+data HasInfo
+data NoInfo
-- | Constructs a Property
mkProperty
:: Desc -- ^ description of the property
-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
-> Info -- ^ info associated with the property
- -> [Property] -- ^ child properties
- -> Property
-mkProperty d a i cs
- | isEmpty i && all isEmpty (map propertyInfo cs) =
- SProperty (GSProperty d a cs)
- | otherwise = IProperty (GIProperty d a i cs)
-
-instance Show Property where
- show p = "property " ++ show (propertyDesc p)
+ -> [Property i] -- ^ child properties
+ -> Property HasInfo
+mkProperty d a i cs = IProperty d a i (map toIProperty cs)
--- | This GADT allows creating operations that only act on Properties
--- that do not add Info to their Host.
-data GProperty i where
- GIProperty :: Desc -> Propellor Result -> Info -> [Property] -> GProperty HasInfo
- GSProperty :: Desc -> Propellor Result -> [Property] -> GProperty NoInfo
+toIProperty :: Property i -> Property HasInfo
+toIProperty p@(IProperty {}) = p
+toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
-data HasInfo
-data NoInfo
+toSProperty :: Property i -> Property NoInfo
+toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
+toSProperty p@(SProperty {}) = p
+
+-- | Makes a version of a Proprty without its Info.
+-- Use with caution!
+ignoreInfo :: Property HasInfo -> Property NoInfo
+ignoreInfo = toSProperty
-propertyDesc :: Property -> Desc
-propertyDesc (IProperty (GIProperty d _ _ _)) = d
-propertyDesc (SProperty (GSProperty d _ _)) = d
+instance Show (Property i) where
+ show p = "property " ++ show (propertyDesc p)
-propertySatisfy :: Property -> Propellor Result
-propertySatisfy (IProperty (GIProperty _ a _ _)) = a
-propertySatisfy (SProperty (GSProperty _ a _)) = a
+propertyDesc :: Property i -> Desc
+propertyDesc (IProperty d _ _ _) = d
+propertyDesc (SProperty d _ _) = d
-propertyInfo :: Property -> Info
-propertyInfo (IProperty (GIProperty _ _ i _)) = i
-propertyInfo (SProperty _) = mempty
+propertySatisfy :: Property i -> Propellor Result
+propertySatisfy (IProperty _ a _ _) = a
+propertySatisfy (SProperty _ a _) = a
+
+propertyInfo :: Property i -> Info
+propertyInfo (IProperty _ _ i _) = i
+propertyInfo (SProperty {}) = mempty
-- | A Property can include a list of child properties that it also
-- satisfies. This allows them to be introspected to collect their info, etc.
-propertyChildren :: Property -> [Property]
-propertyChildren (IProperty (GIProperty _ _ _ cs)) = cs
-propertyChildren (SProperty (GSProperty _ _ cs)) = cs
+propertyChildren :: Property i -> [Property i]
+propertyChildren (IProperty _ _ _ cs) = cs
+propertyChildren (SProperty _ _ cs) = cs
-- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)
+
+mkRevertableProperty :: Property i1 -> Property i2 -> RevertableProperty
+mkRevertableProperty p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
class IsProp p where
-- | Sets description.
describe :: p -> Desc -> p
- toProp :: p -> Property
- -- | Indicates that the first property can only be satisfied
- -- once the second one is.
- requires :: p -> Property -> p
+ toProp :: p -> Property HasInfo
-- | Gets the info of the property, combined with all info
-- of all children properties.
getInfoRecursive :: p -> Info
-instance IsProp Property where
- describe (IProperty (GIProperty _ a i cs)) d =
- IProperty (GIProperty d a i cs)
- describe (SProperty (GSProperty _ a cs)) d =
- SProperty (GSProperty d a cs)
- toProp p = p
- getInfoRecursive (IProperty (GIProperty _ _ i cs)) =
+instance IsProp (Property HasInfo) where
+ describe (IProperty _ a i cs) d = IProperty d a i cs
+ toProp = id
+ getInfoRecursive (IProperty _ _ i cs) =
i <> mconcat (map getInfoRecursive cs)
- getInfoRecursive (SProperty _) = mempty
- x `requires` y = mkProperty (propertyDesc x) satisfy (propertyInfo x) cs
- where
- satisfy = do
- r <- propertySatisfy y
- case r of
- FailedChange -> return FailedChange
- _ -> propertySatisfy x
- cs = y : propertyChildren x
+instance IsProp (Property NoInfo) where
+ describe (SProperty _ a cs) d = SProperty d a cs
+ toProp = toIProperty
+ getInfoRecursive _ = mempty
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
describe (RevertableProperty p1 p2) d =
RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
toProp (RevertableProperty p1 _) = p1
- (RevertableProperty p1 p2) `requires` y =
- RevertableProperty (p1 `requires` y) p2
-- | Return the Info of the currently active side.
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
-type Desc = String
+class Requires x y r where
+ -- Indicates that the first property depends on the second,
+ -- so before the first is ensured, the second will be ensured.
+ requires :: x -> y -> r
+
+instance Requires (Property HasInfo) (Property HasInfo) (Property HasInfo) where
+ requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (a2 `andThen` a1) i1 (y : cs1)
+
+instance Requires (Property HasInfo) (Property NoInfo) (Property HasInfo) where
+ requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+ IProperty d1 (a2 `andThen` a1) i1 (toIProperty y : cs1)
+
+instance Requires (Property NoInfo) (Property HasInfo) (Property HasInfo) where
+ requires x y = requires y x
+
+instance Requires (Property NoInfo) (Property NoInfo) (Property NoInfo) where
+ requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
+ SProperty d1 (a2 `andThen` a1) (y : cs1)
+
+instance Requires RevertableProperty (Property HasInfo) RevertableProperty where
+ requires (RevertableProperty p1 p2) y =
+ RevertableProperty (p1 `requires` y) p2
+
+instance Requires RevertableProperty (Property NoInfo) RevertableProperty where
+ requires (RevertableProperty p1 p2) y =
+ RevertableProperty (p1 `requires` toIProperty y) p2
+
+instance Requires RevertableProperty RevertableProperty RevertableProperty where
+ requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) =
+ RevertableProperty
+ (x1 `requires` y1)
+ -- when reverting, run actions in reverse order
+ (y2 `requires` x2)
+
+andThen :: Propellor Result -> Propellor Result -> Propellor Result
+x `andThen` y = do
+ r <- x
+ case r of
+ FailedChange -> return FailedChange
+ _ -> y
-- | Information about a host.
data Info = Info