{-# LANGUAGE DataKinds, TypeFamilies #-} module Propellor.Container where import Propellor.Types import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.Info import Propellor.PrivData import Propellor.PropAccum class IsContainer c where containerProperties :: c -> [ChildProperty] containerInfo :: c -> Info setContainerProperties :: c -> [ChildProperty] -> c instance IsContainer Host where containerProperties = hostProperties containerInfo = hostInfo setContainerProperties h ps = host (hostName h) (Props ps) -- | Note that the metatype of a container's properties is not retained, -- so this defaults to UnixLike. So, using this with setContainerProps can -- add properties to a container that conflict with properties already in it. -- Use caution when using this; only add properties that do not have -- restricted targets. containerProps :: IsContainer c => c -> Props UnixLike containerProps = Props . containerProperties setContainerProps :: IsContainer c => c -> Props metatypes -> c setContainerProps c (Props ps) = setContainerProperties c ps -- | Adjust the provided Property, adding to its -- propertyChidren the properties of the provided container. -- -- The Info of the propertyChildren is adjusted to only include -- info that should be propagated out to the Property. -- -- Any PrivInfo that uses HostContext is adjusted to use the name -- of the container as its context. propagateContainer :: -- Since the children being added probably have info, -- require the Property's metatypes to have info. -- -Wredundant-constraints is turned off because -- this constraint appears redundant, but is actually -- crucial. ( IncludesInfo metatypes ~ 'True , IsContainer c ) => String -> c -> (PropagateInfo -> Bool) -> Property metatypes -> Property metatypes propagateContainer containername c wanted prop = prop `addChildren` map convert (containerProperties c) where convert p = let n = property'' (getDesc p) (getSatisfy p) :: Property UnixLike n' = n `setInfoProperty` mapInfo (forceHostContext containername) (propagatableInfo wanted (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' -- | Filters out parts of the Info that should not propagate out of a -- container. propagatableInfo :: (PropagateInfo -> Bool) -> Info -> Info propagatableInfo wanted (Info l) = Info $ filter (\(InfoEntry a) -> wanted (propagateInfo a)) l normalContainerInfo :: PropagateInfo -> Bool normalContainerInfo PropagatePrivData = True normalContainerInfo (PropagateInfo b) = b onlyPrivData :: PropagateInfo -> Bool onlyPrivData PropagatePrivData = True onlyPrivData (PropagateInfo _) = False