From 45c94ffdd79b4f8134ef651b08fedb57b37448e6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Jan 2015 16:54:49 -0400 Subject: moving to using the GADT The problem this exposes has to do with requires. As implemented, requires yields either a Property HasInfo or a Property NoInfo depending on its inputs. That works. But look what happens when it's used: *Propellor.Types> let foo = IProperty "foo" (return NoChange) mempty mempty *Propellor.Types> let bar = IProperty "bar" (return NoChange) mempty mempty *Propellor.Types> foo `requires` bar :17:5: No instance for (Requires (Property HasInfo) (Property HasInfo) r0) arising from a use of `requires' The type variable `r0' is ambiguous Possible fix: add a type signature that fixes these type variable(s) Note: there is a potential instance available: instance Requires (Property HasInfo) (Property HasInfo) (Property HasInfo) -- Defined at Propellor/Types.hs:167:10 Possible fix: add an instance declaration for (Requires (Property HasInfo) (Property HasInfo) r0) In the expression: foo `requires` bar In an equation for `it': it = foo `requires` bar This can be avoided by specifying the result type: *Propellor.Types> (foo `requires` bar) :: Property HasInfo property "foo" But then when multiple `requires` are given, the result type has to be given each time: *Propellor.Types> (foo `requires` bar `requires` bar) :: Property HasInfo :22:6: No instance for (Requires (Property HasInfo) (Property HasInfo) x0) arising from a use of `requires' The type variable `x0' is ambiguous Possible fix: add a type signature that fixes these type variable(s) Note: there is a potential instance available: instance Requires (Property HasInfo) (Property HasInfo) (Property HasInfo) -- Defined at Propellor/Types.hs:167:10 Possible fix: add an instance declaration for (Requires (Property HasInfo) (Property HasInfo) x0) In the first argument of `requires', namely `foo `requires` bar' In the expression: (foo `requires` bar `requires` bar) :: Property HasInfo In an equation for `it': it = (foo `requires` bar `requires` bar) :: Property HasInfo :22:21: No instance for (Requires x0 (Property HasInfo) (Property HasInfo)) arising from a use of `requires' The type variable `x0' is ambiguous Possible fix: add a type signature that fixes these type variable(s) Note: there are several potential instances: instance Requires (Property NoInfo) (Property HasInfo) (Property HasInfo) -- Defined at Propellor/Types.hs:175:10 instance Requires (Property HasInfo) (Property HasInfo) (Property HasInfo) -- Defined at Propellor/Types.hs:167:10 Possible fix: add an instance declaration for (Requires x0 (Property HasInfo) (Property HasInfo)) In the expression: (foo `requires` bar `requires` bar) :: Property HasInfo In an equation for `it': it = (foo `requires` bar `requires` bar) :: Property HasInfo *Propellor.Types> (((foo `requires` bar) :: Property HasInfo) `requires` bar) :: Property HasInfo property "foo" Yuggh! --- src/Propellor/Engine.hs | 9 ++- src/Propellor/Info.hs | 12 ++-- src/Propellor/Types.hs | 155 +++++++++++++++++++++++++++++++----------------- 3 files changed, 110 insertions(+), 66 deletions(-) (limited to 'src') 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 -- cgit v1.2.3