summaryrefslogtreecommitdiff
path: root/src/Propellor/Container.hs
blob: c4d6f86447e40ac4ca232b70a6c0de566914d6a3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
{-# 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.
		( IncludesInfo metatypes ~ 'True
		, IsContainer c
		)
	=> String
	-> c
	-> Property metatypes
	-> Property metatypes
propagateContainer containername c 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 (getInfo p))
		   	`addChildren` map convert (getChildren p)
		in toChildProperty n'