summaryrefslogtreecommitdiff
path: root/src/Propellor/Types/Dns.hs
blob: 21a4860c1b0f2c908c53010197fbe5adc0be50df (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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

module Propellor.Types.Dns where

import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
import Propellor.Types.Info
import Propellor.Types.ConfigurableValue
import Utility.Split

import Data.Word
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Semigroup as Sem
import Data.List
import Data.Monoid
import Prelude

type Domain = String

data IPAddr = IPv4 String | IPv6 String
	deriving (Read, Show, Eq, Ord)

instance ConfigurableValue IPAddr where
	val (IPv4 addr) = addr
	val (IPv6 addr) = addr

newtype AliasesInfo = AliasesInfo (S.Set HostName)
	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

instance IsInfo AliasesInfo where
	propagateInfo _ = PropagateInfo False

toAliasesInfo :: [HostName] -> AliasesInfo
toAliasesInfo l = AliasesInfo (S.fromList l)

fromAliasesInfo :: AliasesInfo -> [HostName]
fromAliasesInfo (AliasesInfo s) = S.toList s

-- | Use this for DNS Info that should propagate from a container to a
-- host. For example, this can be used for CNAME to make aliases
-- of the containers in the host be reflected in the DNS.
newtype DnsInfoPropagated = DnsInfoPropagated
	{ fromDnsInfoPropagated :: S.Set Record }
	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated
toDnsInfoPropagated = DnsInfoPropagated

instance IsInfo DnsInfoPropagated where
	propagateInfo _ = PropagateInfo True

-- | Use this for DNS Info that should not propagate from a container to a
-- host. For example, an IP address of a container should not influence
-- the host.
newtype DnsInfoUnpropagated = DnsInfoUnpropagated
	{ fromDnsInfoUnpropagated :: S.Set Record }
	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated
toDnsInfoUnpropagated = DnsInfoUnpropagated

-- | Get all DNS Info.
getDnsInfo :: Info -> S.Set Record
getDnsInfo i = fromDnsInfoUnpropagated (fromInfo i)
	`S.union` fromDnsInfoPropagated (fromInfo i)

instance IsInfo DnsInfoUnpropagated where
	propagateInfo _ = PropagateInfo False

-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
	{ confDomain :: Domain
	, confDnsServerType :: DnsServerType
	, confFile :: FilePath
	, confMasters :: [IPAddr]
	, confAllowTransfer :: [IPAddr]
	, confLines :: [String]
	}
	deriving (Show, Eq, Ord)

data DnsServerType = Master | Secondary
	deriving (Show, Eq, Ord)

-- | Represents a bind 9 zone file.
data Zone = Zone
	{ zDomain :: Domain
	, zSOA :: SOA
	, zHosts :: [(BindDomain, Record)]
	}
	deriving (Read, Show, Eq)

-- | Every domain has a SOA record, which is big and complicated.
data SOA = SOA
	{ sDomain :: BindDomain
	-- ^ Typically ns1.your.domain
	, sSerial :: SerialNumber
	-- ^ The most important parameter is the serial number,
	-- which must increase after each change.
	, sRefresh :: Integer
	, sRetry :: Integer
	, sExpire :: Integer
	, sNegativeCacheTTL :: Integer
	}
	deriving (Read, Show, Eq)

-- | Types of DNS records.
--
-- This is not a complete list, more can be added.
data Record
	= Address IPAddr
	| CNAME BindDomain
	| MX Int BindDomain
	| NS BindDomain
	| TXT String
	| SRV Word16 Word16 Word16 BindDomain
	| SSHFP Int Int String
	| INCLUDE FilePath
	| PTR ReverseIP
	deriving (Read, Show, Eq, Ord, Typeable)

-- | An in-addr.arpa record corresponding to an IPAddr.
type ReverseIP = String

reverseIP :: IPAddr -> ReverseIP
reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa"
reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa"

-- | Converts an IP address (particularly IPv6) to canonical, fully
-- expanded form.
canonicalIP :: IPAddr -> IPAddr
canonicalIP (IPv4 addr) = IPv4 addr
canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr
  where
	canonicalGroup g
		| l <= 4    = replicate (4 - l) '0' ++ g
		| otherwise = error $ "IPv6 group " ++ g ++ "as more than 4 hex digits"
	  where
		l = length g
	emptyGroups n = iterate (++ ":") "" !! n
	numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a)
	replaceImplicitGroups a = concat $ aux $ split "::" a
	  where
		aux [] = []
		aux (x : xs) = x : emptyGroups (numberOfImplicitGroups a) : xs

getIPAddr :: Record -> Maybe IPAddr
getIPAddr (Address addr) = Just addr
getIPAddr _ = Nothing

getCNAME :: Record -> Maybe BindDomain
getCNAME (CNAME d) = Just d
getCNAME _ = Nothing

getNS :: Record -> Maybe BindDomain
getNS (NS d) = Just d
getNS _ = Nothing

-- | Bind serial numbers are unsigned, 32 bit integers.
type SerialNumber = Word32

-- | Domains in the zone file must end with a period if they are absolute.
--
-- Let's use a type to keep absolute domains straight from relative
-- domains.
--
-- The RootDomain refers to the top level of the domain, so can be used
-- to add nameservers, MX's, etc to a domain.
data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain
	deriving (Read, Show, Eq, Ord)

domainHostName :: BindDomain -> Maybe HostName
domainHostName (RelDomain d) = Just d
domainHostName (AbsDomain d) = Just d
domainHostName RootDomain = Nothing

newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
	deriving (Eq, Ord, Show, Typeable)

instance IsInfo NamedConfMap where
	propagateInfo _ = PropagateInfo False

-- | Adding a Master NamedConf stanza for a particulr domain always
-- overrides an existing Secondary stanza for that domain, while a
-- Secondary stanza is only added when there is no existing Master stanza.
instance Sem.Semigroup NamedConfMap where
	NamedConfMap old <> NamedConfMap new = NamedConfMap $
		M.unionWith combiner new old
	  where
		combiner n o = case (confDnsServerType n, confDnsServerType o) of
			(Secondary, Master) -> o
			_  -> n

instance Monoid NamedConfMap where
	mempty = NamedConfMap M.empty
	mappend = (<>)

instance Empty NamedConfMap where
	isEmpty (NamedConfMap m) = isEmpty m

fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf
fromNamedConfMap (NamedConfMap m) = m