moved source code to src

This is to work around OSX's brain-damange regarding filename case
insensitivity.

Avoided moving config.hs, because it's a config file. Put in a symlink to
make build work.

1 files changed, 405 insertions, 0 deletions

diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
new file mode 100644
index 00000000..5c3162cb
--- /dev/null
+++ b/src/Propellor/Property/Dns.hs
@@ -0,0 +1,405 @@
+module Propellor.Property.Dns (
+	module Propellor.Types.Dns,
+	primary,
+	secondary,
+	secondaryFor,
+	mkSOA,
+	writeZoneFile,
+	nextSerialNumber,
+	adjustSerialNumber,
+	serialNumberOffset,
+	WarningMessage,
+	genZone,
+) where
+
+import Propellor
+import Propellor.Types.Dns
+import Propellor.Property.File
+import Propellor.Types.Attr
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+import Utility.Applicative
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.List
+
+-- | Primary dns server for a domain.
+--
+-- Most of the content of the zone file is configured by setting properties
+-- of hosts. For example,
+--
+-- > host "foo.example.com"
+-- >   & ipv4 "192.168.1.1"
+-- >   & alias "mail.exmaple.com"
+--
+-- Will cause that hostmame and its alias to appear in the zone file,
+-- with the configured IP address.
+--
+-- The [(BindDomain, Record)] list can be used for additional records
+-- that cannot be configured elsewhere. This often includes NS records,
+-- TXT records and perhaps CNAMEs pointing at hosts that propellor does
+-- not control.
+--
+-- The primary server is configured to only allow zone transfers to
+-- secondary dns servers. These are determined in two ways:
+--
+-- 1. By looking at the properties of other hosts, to find hosts that
+-- are configured as the secondary dns server.
+--
+-- 2. By looking for NS Records in the passed list of records.
+--
+-- In either case, the secondary dns server Host should have an ipv4 and/or
+-- ipv6 property defined.
+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
+primary hosts domain soa rs = RevertableProperty setup cleanup
+  where
+	setup = withwarnings (check needupdate baseprop)
+		`requires` servingZones
+		`onChange` Service.reloaded "bind9"
+	cleanup = check (doesFileExist zonefile) $
+		property ("removed dns primary for " ++ domain)
+			(makeChange $ removeZoneFile zonefile)
+			`requires` namedConfWritten
+			`onChange` Service.reloaded "bind9"
+
+	(partialzone, zonewarnings) = genZone hosts domain soa
+	zone = partialzone { zHosts = zHosts partialzone ++ rs }
+	zonefile = "/etc/bind/propellor/db." ++ domain
+	baseprop = Property ("dns primary for " ++ domain)
+		(makeChange $ writeZoneFile zone zonefile)
+		(addNamedConf conf)
+	withwarnings p = adjustProperty p $ \satisfy -> do
+		mapM_ warningMessage $ zonewarnings ++ secondarywarnings
+		satisfy
+	conf = NamedConf
+		{ confDomain = domain
+		, confDnsServerType = Master
+		, confFile = zonefile
+		, confMasters = []
+		, confAllowTransfer = nub $
+			concatMap (\h -> hostAddresses h hosts) $
+				secondaries ++ nssecondaries
+		, confLines = []
+		}
+	secondaries = otherServers Secondary hosts domain
+	secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $
+		filter (\h -> null (hostAddresses h hosts)) secondaries
+	nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords
+	rootRecords = map snd $
+		filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs
+	needupdate = do
+		v <- readZonePropellorFile zonefile
+		return $ case v of
+			Nothing -> True
+			Just oldzone ->
+				-- compare everything except serial
+				let oldserial = sSerial (zSOA oldzone)
+				    z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }
+				in z /= oldzone || oldserial < sSerial (zSOA zone)
+
+-- | Secondary dns server for a domain.
+--
+-- The primary server is determined by looking at the properties of other
+-- hosts to find which one is configured as the primary.
+--
+-- Note that if a host is declared to be a primary and a secondary dns
+-- server for the same domain, the primary server config always wins.
+secondary :: [Host] -> Domain -> RevertableProperty
+secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
+
+-- | This variant is useful if the primary server does not have its DNS
+-- configured via propellor.
+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
+secondaryFor masters hosts domain = RevertableProperty setup cleanup
+  where
+	setup = pureAttrProperty desc (addNamedConf conf)
+		`requires` servingZones
+	cleanup = namedConfWritten
+
+ 	desc = "dns secondary for " ++ domain
+	conf = NamedConf
+		{ confDomain = domain
+		, confDnsServerType = Secondary
+		, confFile = "db." ++ domain
+		, confMasters = concatMap (\m -> hostAddresses m hosts) masters
+		, confAllowTransfer = []
+		, confLines = []
+		}
+
+otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
+otherServers wantedtype hosts domain =
+	M.keys $ M.filter wanted $ hostAttrMap hosts
+  where
+	wanted attr = case M.lookup domain (_namedconf attr) of
+		Nothing -> False
+		Just conf -> confDnsServerType conf == wantedtype
+			&& confDomain conf == domain
+
+-- | Rewrites the whole named.conf.local file to serve the zones
+-- configured by `primary` and `secondary`, and ensures that bind9 is
+-- running.
+servingZones :: Property
+servingZones = namedConfWritten
+	`onChange` Service.reloaded "bind9"
+	`requires` Apt.serviceInstalledRunning "bind9"
+
+namedConfWritten :: Property
+namedConfWritten = property "named.conf configured" $ do
+	zs <- getNamedConf
+	ensureProperty $
+		hasContent namedConfFile $
+			concatMap confStanza $ M.elems zs
+
+confStanza :: NamedConf -> [Line]
+confStanza c =
+	[ "// automatically generated by propellor"
+	, "zone \"" ++ confDomain c ++ "\" {"
+	, cfgline "type" (if confDnsServerType c == Master then "master" else "slave")
+	, cfgline "file" ("\"" ++ confFile c ++ "\"")
+	] ++
+	mastersblock ++
+	allowtransferblock ++
+	(map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
+	[ "};"
+	, ""
+	]
+  where
+	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
+	ipblock name l = 
+		[ "\t" ++ name ++ " {" ] ++
+		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++
+		[ "\t};" ]
+	mastersblock
+		| null (confMasters c) = []
+		| otherwise = ipblock "masters" (confMasters c)
+	-- an empty block prohibits any transfers
+	allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)
+
+namedConfFile :: FilePath
+namedConfFile = "/etc/bind/named.conf.local"
+
+-- | Generates a SOA with some fairly sane numbers in it.
+--
+-- The Domain is the domain to use in the SOA record. Typically
+-- something like ns1.example.com. So, not the domain that this is the SOA
+-- record for.
+--
+-- The SerialNumber can be whatever serial number was used by the domain
+-- before propellor started managing it. Or 0 if the domain has only ever
+-- been managed by propellor.
+--
+-- You do not need to increment the SerialNumber when making changes!
+-- Propellor will automatically add the number of commits in the git
+-- repository to the SerialNumber.
+mkSOA :: Domain -> SerialNumber -> SOA
+mkSOA d sn = SOA
+	{ sDomain = AbsDomain d
+	, sSerial = sn
+	, sRefresh = hours 4
+	, sRetry = hours 1
+	, sExpire = 2419200 -- 4 weeks
+	, sNegativeCacheTTL = hours 8
+	}
+  where
+	hours n = n * 60 * 60
+
+dValue :: BindDomain -> String
+dValue (RelDomain d) = d
+dValue (AbsDomain d) = d ++ "."
+dValue (RootDomain) = "@"
+
+rField :: Record -> String
+rField (Address (IPv4 _)) = "A"
+rField (Address (IPv6 _)) = "AAAA"
+rField (CNAME _) = "CNAME"
+rField (MX _ _) = "MX"
+rField (NS _) = "NS"
+rField (TXT _) = "TXT"
+rField (SRV _ _ _ _) = "SRV"
+
+rValue :: Record -> String
+rValue (Address (IPv4 addr)) = addr
+rValue (Address (IPv6 addr)) = addr
+rValue (CNAME d) = dValue d
+rValue (MX pri d) = show pri ++ " " ++ dValue d
+rValue (NS d) = dValue d
+rValue (SRV priority weight port target) = unwords
+	[ show priority
+	, show weight
+	, show port
+	, dValue target
+	]
+rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
+  where
+	q = '"'
+
+-- | Adjusts the serial number of the zone to always be larger
+-- than the serial number in the Zone record,
+-- and always be larger than the passed SerialNumber.
+nextSerialNumber :: Zone -> SerialNumber -> Zone
+nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial
+
+adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone
+adjustSerialNumber (Zone d soa l) f = Zone d soa' l
+  where
+	soa' = soa { sSerial = f (sSerial soa) }
+
+-- | Count the number of git commits made to the current branch.
+serialNumberOffset :: IO SerialNumber
+serialNumberOffset = fromIntegral . length . lines
+	<$> readProcess "git" ["log", "--pretty=%H"]
+
+-- | Write a Zone out to a to a file.
+--
+-- The serial number in the Zone automatically has the serialNumberOffset
+-- added to it. Also, just in case, the old serial number used in the zone
+-- file is checked, and if it is somehow larger, its succ is used.
+writeZoneFile :: Zone -> FilePath -> IO ()
+writeZoneFile z f = do
+	oldserial <- oldZoneFileSerialNumber f
+	offset <- serialNumberOffset
+	let z' = nextSerialNumber
+		(adjustSerialNumber z (+ offset))
+		oldserial
+	createDirectoryIfMissing True (takeDirectory f)
+	writeFile f (genZoneFile z')
+	writeZonePropellorFile f z'
+
+removeZoneFile :: FilePath -> IO ()
+removeZoneFile f = do
+	nukeFile f
+	nukeFile (zonePropellorFile f)
+
+-- | Next to the zone file, is a ".propellor" file, which contains
+-- the serialized Zone. This saves the bother of parsing
+-- the horrible bind zone file format.
+zonePropellorFile :: FilePath -> FilePath
+zonePropellorFile f = f ++ ".propellor"
+
+oldZoneFileSerialNumber :: FilePath -> IO SerialNumber
+oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile
+
+writeZonePropellorFile :: FilePath -> Zone -> IO ()
+writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)
+
+readZonePropellorFile :: FilePath -> IO (Maybe Zone)
+readZonePropellorFile f = catchDefaultIO Nothing $
+	readish <$> readFileStrict (zonePropellorFile f)
+
+-- | Generating a zone file.
+genZoneFile :: Zone -> String
+genZoneFile (Zone zdomain soa rs) = unlines $
+	header : genSOA soa ++ map (genRecord zdomain) rs
+  where
+	header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."
+
+genRecord :: Domain -> (BindDomain, Record) -> String
+genRecord zdomain (domain, record) = intercalate "\t"
+	[ domainHost zdomain domain
+	, "IN"
+	, rField record
+	, rValue record
+	]
+
+genSOA :: SOA -> [String]
+genSOA soa = 
+	-- "@ IN SOA ns1.example.com. root ("
+	[ intercalate "\t"
+		[ dValue RootDomain 
+		, "IN"
+		, "SOA"
+		, dValue (sDomain soa)
+		, "root"
+		, "("
+		]
+	, headerline sSerial "Serial"
+	, headerline sRefresh "Refresh"
+	, headerline sRetry "Retry"
+	, headerline sExpire "Expire"
+	, headerline sNegativeCacheTTL "Negative Cache TTL"
+	, inheader ")"
+	]
+  where
+	headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment
+	inheader l = "\t\t\t" ++ l
+
+-- | Comment line in a zone file.
+com :: String -> String
+com s = "; " ++ s
+
+type WarningMessage = String
+
+-- | Generates a Zone for a particular Domain from the DNS properies of all
+-- hosts that propellor knows about that are in that Domain.
+genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage])
+genZone hosts zdomain soa =
+	let (warnings, zhosts) = partitionEithers $ concat $ map concat
+		[ map hostips inzdomain
+		, map hostrecords inzdomain
+		, map addcnames (M.elems m)
+		]
+	in (Zone zdomain soa (nub zhosts), warnings)
+  where
+	m = hostAttrMap hosts
+	-- Known hosts with hostname located in the zone's domain.
+	inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m
+	
+	-- Each host with a hostname located in the zdomain
+	-- should have 1 or more IPAddrs in its Attr.
+	--
+	-- If a host lacks any IPAddr, it's probably a misconfiguration,
+	-- so warn.
+	hostips :: Attr -> [Either WarningMessage (BindDomain, Record)]
+	hostips attr
+		| null l = [Left $ "no IP address defined for host " ++ _hostname attr]
+		| otherwise = map Right l
+	  where
+		l = zip (repeat $ AbsDomain $ _hostname attr)
+			(map Address $ getAddresses attr)
+
+	-- Any host, whether its hostname is in the zdomain or not,
+	-- may have cnames which are in the zdomain. The cname may even be
+	-- the same as the root of the zdomain, which is a nice way to
+	-- specify IP addresses for a SOA record.
+	--
+	-- Add Records for those.. But not actually, usually, cnames!
+	-- Why not? Well, using cnames doesn't allow doing some things,
+	-- including MX and round robin DNS, and certianly CNAMES
+	-- shouldn't be used in SOA records.
+	--
+	-- We typically know the host's IPAddrs anyway.
+	-- So we can just use the IPAddrs.
+	addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)]
+	addcnames attr = concatMap gen $ filter (inDomain zdomain) $
+		mapMaybe getCNAME $ S.toList (_dns attr)
+	  where
+		gen c = case getAddresses attr of
+			[] -> [ret (CNAME c)]
+			l -> map (ret . Address) l
+		  where
+		  	ret record = Right (c, record)
+	
+	-- Adds any other DNS records for a host located in the zdomain.
+	hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)]
+	hostrecords attr = map Right l
+	  where
+		l = zip (repeat $ AbsDomain $ _hostname attr)
+			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))
+
+inDomain :: Domain -> BindDomain -> Bool
+inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d
+inDomain _ _ = False -- can't tell, so assume not
+
+-- | Gets the hostname of the second domain, relative to the first domain,
+-- suitable for using in a zone file.
+domainHost :: Domain -> BindDomain -> String
+domainHost _ (RelDomain d) = d
+domainHost _ RootDomain = "@"
+domainHost base (AbsDomain d)
+	| dotbase `isSuffixOf` d = take (length d - length dotbase) d
+	| base == d = "@"
+	| otherwise = d
+  where
+	dotbase = '.':base
+