propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Types.hs (10660B)


      1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
      2 {-# LANGUAGE FlexibleInstances #-}
      3 {-# LANGUAGE UndecidableInstances #-}
      4 {-# LANGUAGE FlexibleContexts #-}
      5 {-# LANGUAGE MultiParamTypeClasses #-}
      6 {-# LANGUAGE TypeFamilies #-}
      7 {-# LANGUAGE ConstraintKinds #-}
      8 {-# LANGUAGE PolyKinds #-}
      9 {-# LANGUAGE DataKinds #-}
     10 {-# LANGUAGE DeriveDataTypeable #-}
     11 
     12 module Propellor.Types (
     13 	-- * Core data types
     14 	  Host(..)
     15 	, Property(..)
     16 	, property
     17 	, property''
     18 	, Desc
     19 	, RevertableProperty(..)
     20 	, (<!>)
     21 	, Propellor(..)
     22 	, LiftPropellor(..)
     23 	, Info
     24 	-- * Types of properties
     25 	, UnixLike
     26 	, Linux
     27 	, DebianLike
     28 	, Debian
     29 	, Buntish
     30 	, ArchLinux
     31 	, FreeBSD
     32 	, HasInfo
     33 	, type (+)
     34 	, TightenTargets(..)
     35 	, TightenTargetsAllowed
     36 	-- * Combining and modifying properties
     37 	, Combines(..)
     38 	, CombinedType
     39 	, ResultCombiner
     40 	, adjustPropertySatisfy
     41 	-- * Other included types
     42 	, module Propellor.Types.OS
     43 	, module Propellor.Types.ConfigurableValue
     44 	, module Propellor.Types.Dns
     45 	, module Propellor.Types.Result
     46 	, module Propellor.Types.ZFS
     47 	) where
     48 
     49 import GHC.TypeLits hiding (type (+))
     50 import GHC.Exts (Constraint)
     51 import Data.Type.Bool
     52 import qualified Data.Semigroup as Sem
     53 import Data.Monoid
     54 import Control.Applicative
     55 import Prelude
     56 
     57 import Propellor.Types.Core
     58 import Propellor.Types.Info
     59 import Propellor.Types.OS
     60 import Propellor.Types.ConfigurableValue
     61 import Propellor.Types.Dns
     62 import Propellor.Types.Result
     63 import Propellor.Types.MetaTypes
     64 import Propellor.Types.ZFS
     65 
     66 -- | The core data type of Propellor, this represents a property
     67 -- that the system should have, with a description, and an action to ensure
     68 -- it has the property.
     69 --
     70 -- There are different types of properties that target different OS's,
     71 -- and so have different metatypes. 
     72 -- For example: "Property DebianLike" and "Property FreeBSD".
     73 --
     74 -- Also, some properties have associated `Info`, which is indicated in
     75 -- their type: "Property (HasInfo + DebianLike)"
     76 --
     77 -- There are many associated type families, which are mostly used
     78 -- internally, so you needn't worry about them.
     79 data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty]
     80 
     81 instance Show (Property metatypes) where
     82 	show p = "property " ++ show (getDesc p)
     83 
     84 -- | Constructs a Property, from a description and an action to run to
     85 -- ensure the Property is met.
     86 --
     87 -- Due to the polymorphic return type of this function, most uses will need
     88 -- to specify a type signature. This lets you specify what OS the property
     89 -- targets, etc.
     90 --
     91 -- For example:
     92 --
     93 -- > foo :: Property Debian
     94 -- > foo = property "foo" $ do
     95 -- >	...
     96 -- > 	return MadeChange
     97 property
     98 	:: SingI metatypes
     99 	=> Desc
    100 	-> Propellor Result
    101 	-> Property (MetaTypes metatypes)
    102 property d a = Property sing d (Just a) mempty mempty
    103 
    104 property''
    105 	:: SingI metatypes
    106 	=> Desc
    107 	-> Maybe (Propellor Result)
    108 	-> Property (MetaTypes metatypes)
    109 property'' d a = Property sing d a mempty mempty
    110 
    111 -- | Changes the action that is performed to satisfy a property.
    112 adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
    113 adjustPropertySatisfy (Property t d s i c) f = Property t d (f <$> s) i c
    114 
    115 -- | A property that can be reverted. The first Property is run
    116 -- normally and the second is run when it's reverted.
    117 --
    118 -- See `Propellor.Property.Versioned.Versioned` 
    119 -- for a way to use RevertableProperty to define different
    120 -- versions of a host.
    121 data RevertableProperty setupmetatypes undometatypes = RevertableProperty
    122 	{ setupRevertableProperty :: Property setupmetatypes
    123 	, undoRevertableProperty :: Property undometatypes
    124 	}
    125 
    126 instance Show (RevertableProperty setupmetatypes undometatypes) where
    127 	show (RevertableProperty p _) = show p
    128 
    129 -- | Shorthand to construct a revertable property from any two Properties.
    130 (<!>)
    131 	:: Property setupmetatypes
    132 	-> Property undometatypes
    133 	-> RevertableProperty setupmetatypes undometatypes
    134 setup <!> undo = RevertableProperty setup undo
    135 
    136 instance IsProp (Property metatypes) where
    137 	setDesc (Property t _ a i c) d = Property t d a i c
    138 	getDesc (Property _ d _ _ _) = d
    139 	getChildren (Property _ _ _ _ c) = c
    140 	addChildren (Property t d a i c) c' = Property t d a i (c ++ c')
    141 	getInfoRecursive (Property _ _ _ i c) =
    142 		i <> mconcat (map getInfoRecursive c)
    143 	getInfo (Property _ _ _ i _) = i
    144 	toChildProperty (Property _ d a i c) = ChildProperty d a i c
    145 	getSatisfy (Property _ _ a _ _) = a
    146 
    147 instance IsProp (RevertableProperty setupmetatypes undometatypes) where
    148 	-- | Sets the description of both sides.
    149 	setDesc (RevertableProperty p1 p2) d =
    150 		RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
    151 	getDesc (RevertableProperty p1 _) = getDesc p1
    152 	getChildren (RevertableProperty p1 _) = getChildren p1
    153 	-- | Only add children to the active side.
    154 	addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2
    155 	-- | Return the Info of the currently active side.
    156 	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
    157 	getInfo (RevertableProperty p1 _p2) = getInfo p1
    158 	toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
    159 	getSatisfy (RevertableProperty p1 _) = getSatisfy p1
    160 
    161 -- | Type level calculation of the type that results from combining two
    162 -- types of properties.
    163 type family CombinedType x y where
    164 	CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) =
    165 		Property (MetaTypes (Combine x y))
    166 	CombinedType
    167 		(RevertableProperty (MetaTypes x) (MetaTypes x'))
    168 		(RevertableProperty (MetaTypes y) (MetaTypes y')) =
    169 			RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine x' y'))
    170 	-- When only one of the properties is revertable, the combined
    171 	-- property is not fully revertable, so is not a RevertableProperty.
    172 	CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) =
    173 		Property (MetaTypes (Combine x y))
    174 	CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) =
    175 		Property (MetaTypes (Combine x y))
    176 
    177 type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result)
    178 
    179 class Combines x y where
    180 	-- | Combines together two properties, yielding a property that
    181 	-- has the description and info of the first, and that has the
    182 	-- second property as a child property.
    183 	combineWith
    184 		:: ResultCombiner
    185 		-- ^ How to combine the actions to satisfy the properties.
    186 		-> ResultCombiner
    187 		-- ^ Used when combining revertable properties, to combine
    188 		-- their reversion actions.
    189 		-> x
    190 		-> y
    191 		-> CombinedType x y
    192 
    193 instance (CheckCombinable x y, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
    194 	combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =
    195 		Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1)
    196 instance (CheckCombinable x y, CheckCombinable x' y', SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
    197 	combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
    198 		RevertableProperty
    199 			(combineWith sf tf s1 s2)
    200 			(combineWith tf sf t1 t2)
    201 instance (CheckCombinable x y, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
    202 	combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
    203 instance (CheckCombinable x y, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
    204 	combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
    205 
    206 class TightenTargets p where
    207 	-- | Tightens the MetaType list of a Property (or similar),
    208 	-- to contain fewer targets.
    209 	--
    210 	-- For example, to make a property that uses apt-get, which is only
    211 	-- available on DebianLike systems:
    212 	--
    213 	-- > upgraded :: Property DebianLike
    214 	-- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
    215 	tightenTargets
    216 		:: 
    217 			( TightenTargetsAllowed untightened tightened
    218 			, SingI tightened
    219 			)
    220 		=> p (MetaTypes untightened)
    221 		-> p (MetaTypes tightened)
    222 
    223 -- Note that this uses PolyKinds
    224 type family TightenTargetsAllowed untightened tightened :: Constraint where
    225 	TightenTargetsAllowed untightened tightened =
    226 		If (Targets tightened `IsSubset` Targets untightened
    227 		    && NonTargets untightened `IsSubset` NonTargets tightened)
    228 			('True ~ 'True)
    229 			(IfStuck (Targets tightened)
    230 				(DelayError
    231 					('Text "Unable to infer desired Property type in this use of tightenTargets."
    232 					 ':$$: ('Text "Consider adding a type annotation.")
    233 					)
    234 				)
    235 				(DelayErrorFcf
    236 					('Text "This use of tightenTargets would widen, not narrow, adding: "
    237 					 ':$$: PrettyPrintMetaTypes (Difference (Targets tightened) (Targets untightened))
    238 					)
    239 				)
    240 			)
    241 
    242 instance TightenTargets Property where
    243 	tightenTargets (Property _ d a i c) = Property sing d a i c
    244 
    245 -- | Any type of Property is a Semigroup. When properties x and y are
    246 -- appended together, the resulting property has a description like
    247 -- "x and y". Note that when x fails to be ensured, it will not
    248 -- try to ensure y.
    249 instance SingI metatypes => Sem.Semigroup (Property (MetaTypes metatypes))
    250   where
    251 	Property _ d1 a1 i1 c1 <> Property _ d2 a2 i2 c2 =
    252 	  	Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2)
    253 	  where
    254 		-- Avoid including "noop property" in description
    255 		-- when using eg mconcat.
    256 		d = case (a1, a2) of
    257 			(Just _, Just _) -> d1 <> " and " <> d2
    258 			(Just _, Nothing) -> d1
    259 			(Nothing, Just _) -> d2
    260 			(Nothing, Nothing) -> d1
    261 
    262 -- | Any type of Property is a Monoid.
    263 instance SingI metatypes => Monoid (Property (MetaTypes metatypes))
    264   where
    265 	-- | A property that does nothing.
    266 	mempty = Property sing "noop property" Nothing mempty mempty
    267 	mappend = (Sem.<>)
    268 
    269 -- | Any type of RevertableProperty is a Semigroup. When revertable 
    270 -- properties x and y are appended together, the resulting revertable
    271 -- property has a description like "x and y".
    272 -- Note that when x fails to be ensured, it will not try to ensure y.
    273 instance
    274 	( Sem.Semigroup (Property (MetaTypes setupmetatypes))
    275 	, Sem.Semigroup (Property (MetaTypes undometatypes))
    276 	, SingI setupmetatypes
    277 	, SingI undometatypes
    278 	)
    279 	=> Sem.Semigroup (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))
    280   where
    281 	RevertableProperty s1 u1 <> RevertableProperty s2 u2 =
    282 		RevertableProperty (s1 <> s2) (u2 <> u1)
    283 
    284 instance
    285 	( Monoid (Property (MetaTypes setupmetatypes))
    286 	, Monoid (Property (MetaTypes undometatypes))
    287 	, SingI setupmetatypes
    288 	, SingI undometatypes
    289 	)
    290 	=> Monoid (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))
    291   where
    292 	mempty = RevertableProperty mempty mempty
    293 	mappend = (Sem.<>)