From 3aca4c62203c9586f396f35cb780c4a79fa0c099 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 14:39:17 -0400 Subject: 1st stage integrating MetaTypes --- src/Propellor/Types.hs | 298 ++++++++++++++++++++----------------------------- 1 file changed, 121 insertions(+), 177 deletions(-) (limited to 'src/Propellor/Types.hs') diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 542a1f66..d1a93f47 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -7,23 +7,29 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} module Propellor.Types ( Host(..) , Property , Info - , HasInfo - , NoInfo - , CInfo , Desc - , infoProperty - , simpleProperty + , mkProperty + , MetaType(..) + , OS(..) + , UnixLike + , Debian + , Buntish + , FreeBSD + , HasInfo + , type (+) + , addInfoProperty , adjustPropertySatisfy , propertyInfo , propertyDesc , propertyChildren , RevertableProperty(..) - , MkRevertableProperty(..) , IsProp(..) , Combines(..) , CombinedType @@ -36,7 +42,6 @@ module Propellor.Types , module Propellor.Types.Result , module Propellor.Types.ZFS , propertySatisfy - , ignoreInfo ) where import Data.Monoid @@ -50,13 +55,14 @@ import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns import Propellor.Types.Result +import Propellor.Types.MetaTypes import Propellor.Types.ZFS -- | Everything Propellor knows about a system: Its hostname, -- properties and their collected info. data Host = Host { hostName :: HostName - , hostProperties :: [Property HasInfo] + , hostProperties :: [ChildProperty] , hostInfo :: Info } deriving (Show, Typeable) @@ -103,162 +109,158 @@ 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. +-- that the system should have, with a descrition, an action to ensure +-- it has the property, and perhaps some Info that can be added to Hosts +-- that have the property. -- --- A property can have associated `Info` or not. This is tracked at the --- type level with Property `NoInfo` and Property `HasInfo`. +-- A property has a list of `[MetaType]`, which is part of its type. -- -- There are many instances and type families, which are mostly used -- internally, so you needn't worry about them. -data Property i where - IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo - SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo - --- | Indicates that a Property has associated Info. -data HasInfo --- | Indicates that a Property does not have Info. -data NoInfo - --- | Type level calculation of the combination of HasInfo and/or NoInfo -type family CInfo x y -type instance CInfo HasInfo HasInfo = HasInfo -type instance CInfo HasInfo NoInfo = HasInfo -type instance CInfo NoInfo HasInfo = HasInfo -type instance CInfo NoInfo NoInfo = NoInfo - --- | Constructs a Property with associated Info. -infoProperty - :: 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 i] -- ^ child properties - -> Property HasInfo -infoProperty d a i cs = IProperty d a i (map toIProperty cs) - --- | Constructs a Property with no Info. -simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo -simpleProperty = SProperty - -toIProperty :: Property i -> Property HasInfo -toIProperty p@(IProperty {}) = p -toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs) - -toSProperty :: Property i -> Property NoInfo -toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs) -toSProperty p@(SProperty {}) = p +data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show (ChildProperty desc _ _ _) = desc + +-- | Constructs a Property. +-- +-- You can specify any metatypes that make sense to indicate what OS +-- the property targets, etc. +-- +-- For example: +-- +-- > foo :: Property Debian +-- > foo = mkProperty "foo" (...) +-- +-- Note that using this needs LANGUAGE PolyKinds. +mkProperty + :: SingI metatypes + => Desc + -> Propellor Result + -> Property (Sing metatypes) +mkProperty d a = Property sing d a mempty mempty + +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +addInfoProperty + :: (metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (Sing metatypes') +addInfoProperty (Property metatypes d a i c) newi = Property sing d a (i <> newi) c + +{- -- | Makes a version of a Proprty without its Info. -- Use with caution! -ignoreInfo :: Property i -> Property NoInfo -ignoreInfo = toSProperty +ignoreInfo + :: (metatypes' ~ + => Property metatypes + -> Property (Sing metatypes') +ignoreInfo = + +-} -- | Gets the action that can be run to satisfy a Property. -- You should never run this action directly. Use -- 'Propellor.Engine.ensureProperty` instead. -propertySatisfy :: Property i -> Propellor Result -propertySatisfy (IProperty _ a _ _) = a -propertySatisfy (SProperty _ a _) = a +propertySatisfy :: Property metatypes -> Propellor Result +propertySatisfy (Property _ _ a _ _) = a -- | Changes the action that is performed to satisfy a property. -adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i -adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs -adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs +adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes +adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c -propertyInfo :: Property i -> Info -propertyInfo (IProperty _ _ i _) = i -propertyInfo (SProperty {}) = mempty +propertyInfo :: Property metatypes -> Info +propertyInfo (Property _ _ _ i _) = i -propertyDesc :: Property i -> Desc -propertyDesc (IProperty d _ _ _) = d -propertyDesc (SProperty d _ _) = d +propertyDesc :: Property metatypes -> Desc +propertyDesc (Property _ d _ _ _) = d -instance Show (Property i) where +instance Show (Property metatypes) where show p = "property " ++ show (propertyDesc p) -- | 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 i -> [Property i] -propertyChildren (IProperty _ _ _ cs) = cs -propertyChildren (SProperty _ _ cs) = cs +propertyChildren :: Property metatypes -> [ChildProperty] +propertyChildren (Property _ _ _ _ c) = c -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty i = RevertableProperty - { setupRevertableProperty :: Property i - , undoRevertableProperty :: Property i +data RevertableProperty metatypes = RevertableProperty + { setupRevertableProperty :: Property metatypes + , undoRevertableProperty :: Property metatypes } -instance Show (RevertableProperty i) where +instance Show (RevertableProperty metatypes) where show (RevertableProperty p _) = show p -class MkRevertableProperty i1 i2 where - -- | Shorthand to construct a revertable property. - () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) - -instance MkRevertableProperty HasInfo HasInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo NoInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo HasInfo where - x y = RevertableProperty (toProp x) y -instance MkRevertableProperty HasInfo NoInfo where - x y = RevertableProperty x (toProp y) +-- | Shorthand to construct a revertable property from any two Properties +-- whose MetaTypes can be combined. +() + :: (metatypes ~ (+) metatypes1 metatypes2, SingI metatypes) + => Property metatypes1 + -> Property metatypes2 + -> RevertableProperty (Sing metatypes) +Property _ d1 s1 i1 c1 Property _ d2 s2 i2 c2 = RevertableProperty + (Property sing d1 s1 i1 c1) + (Property sing d2 s2 i2 c2) -- | Class of types that can be used as properties of a host. class IsProp p where setDesc :: p -> Desc -> p - toProp :: p -> Property HasInfo + -- toProp :: p -> Property HasInfo getDesc :: p -> Desc -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info -instance IsProp (Property HasInfo) where - setDesc (IProperty _ a i cs) d = IProperty d a i cs - toProp = id +instance IsProp (Property metatypes) where + setDesc (Property t _ a i c) d = Property t d a i c + -- toProp = id getDesc = propertyDesc - getInfoRecursive (IProperty _ _ i cs) = - i <> mconcat (map getInfoRecursive cs) -instance IsProp (Property NoInfo) where - setDesc (SProperty _ a cs) d = SProperty d a cs - toProp = toIProperty - getDesc = propertyDesc - getInfoRecursive _ = mempty + getInfoRecursive (Property _ _ _ i c) = + i <> mconcat (map getInfoRecursive c) + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) -instance IsProp (RevertableProperty HasInfo) where +instance IsProp (RevertableProperty metatypes) where setDesc = setDescR getDesc (RevertableProperty p1 _) = getDesc p1 - toProp (RevertableProperty p1 _) = p1 + -- toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 -instance IsProp (RevertableProperty NoInfo) where - setDesc = setDescR - getDesc (RevertableProperty p1 _) = getDesc p1 - toProp (RevertableProperty p1 _) = toProp p1 - getInfoRecursive (RevertableProperty _ _) = mempty -- | Sets the description of both sides. -setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i +setDescR :: IsProp (Property metatypes) => RevertableProperty metatypes -> Desc -> RevertableProperty metatypes setDescR (RevertableProperty p1 p2) d = RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y -type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) +type instance CombinedType (Property (Sing x)) (Property (Sing y)) = Property (Sing (Union x y)) +type instance CombinedType (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) = RevertableProperty (Sing (Union x y)) -- When only one of the properties is revertable, the combined property is -- not fully revertable, so is not a RevertableProperty. -type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y) -type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) +type instance CombinedType (RevertableProperty (Sing x)) (Property (Sing y)) = Property (Sing (Union x y)) +type instance CombinedType (Property (Sing x)) (RevertableProperty (Sing y)) = Property (Sing (Union x y)) type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result class Combines x y where -- | Combines together two properties, yielding a property that - -- has the description and info of the first, and that has the second - -- property as a child. + -- has the description and info of the first, and that has the + -- second property as a child property. combineWith :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. @@ -269,73 +271,15 @@ class Combines x y where -> y -> CombinedType x y -instance Combines (Property HasInfo) (Property HasInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) i1 (y : cs1) - -instance Combines (Property HasInfo) (Property NoInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = - IProperty d1 (f a1 a2) i1 (toIProperty y : cs1) - -instance Combines (Property NoInfo) (Property HasInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1) - -instance Combines (Property NoInfo) (Property NoInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = - SProperty d1 (f a1 a2) (y : cs1) - -instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty NoInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (Property HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR - -combineWithRR - :: Combines (Property x) (Property y) - => ResultCombiner - -> ResultCombiner - -> RevertableProperty x - -> RevertableProperty y - -> RevertableProperty (CInfo x y) -combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = - RevertableProperty - (combineWith sf tf s1 s2) - (combineWith tf sf t1 t2) - -combineWithRP - :: Combines (Property i) y - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> RevertableProperty i - -> y - -> CombinedType (Property i) y -combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y - -combineWithPR - :: Combines x (Property i) - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> x - -> RevertableProperty i - -> CombinedType x (Property i) -combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y +instance (CombinedType (Property (Sing x)) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (Property (Sing y)) where + combineWith f _ (Property t1 d1 a1 i1 c1) (Property _t2 d2 a2 i2 c2) = + Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1) +instance (CombinedType (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) ~ RevertableProperty (Sing (Union x y)), SingI (Union x y)) => Combines (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) where + combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) +instance (CombinedType (RevertableProperty (Sing x)) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (RevertableProperty (Sing x)) (Property (Sing y)) where + combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y +instance (CombinedType (Property (Sing x)) (RevertableProperty (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (RevertableProperty (Sing y)) where + combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y -- cgit v1.2.3