added bind 9 zone file creation code

Propellor/Property/Dns.hs

@@ -4,11 +4,14 @@ import Propellor
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
+import Utility.Applicative
+
+import Data.List
 
 namedconf :: FilePath
 namedconf = "/etc/bind/named.conf.local"
 
-data Zone = Zone
+data NamedConf = NamedConf
 	{ zdomain :: Domain
 	, ztype :: Type
 	, zfile :: FilePath
@@ -16,7 +19,7 @@ data Zone = Zone
 	, zconfiglines :: [String]
 	}
 
-zoneDesc :: Zone -> String
+zoneDesc :: NamedConf -> String
 zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"
 
 type IPAddr = String
@@ -26,8 +29,8 @@ type Domain = String
 data Type = Master | Secondary
 	deriving (Show, Eq)
 
-secondary :: Domain -> [IPAddr] -> Zone
-secondary domain masters = Zone
+secondary :: Domain -> [IPAddr] -> NamedConf
+secondary domain masters = NamedConf
 	{ zdomain = domain
 	, ztype = Secondary
 	, zfile = "db." ++ domain
@@ -35,7 +38,7 @@ secondary domain masters = Zone
 	, zconfiglines = ["allow-transfer { }"]
 	}
 
-zoneStanza :: Zone -> [Line]
+zoneStanza :: NamedConf -> [Line]
 zoneStanza z =
 	[ "// automatically generated by propellor"
 	, "zone \"" ++ zdomain z ++ "\" {"
@@ -56,8 +59,160 @@ zoneStanza z =
 
 -- | Rewrites the whole named.conf.local file to serve the specificed
 -- zones.
-zones :: [Zone] -> Property
+zones :: [NamedConf] -> Property
 zones zs = hasContent namedconf (concatMap zoneStanza zs)
 	`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
 	`requires` Apt.serviceInstalledRunning "bind9"
 	`onChange` Service.reloaded "bind9"
+
+-- | Represents a bind 9 zone file.
+data Zone = Zone SOA [(HostName, Record)]
+
+-- | Every domain has a SOA record, which is big and complicated.
+data SOA = SOA
+	{ sRoot :: BindDomain
+	, sSerial :: SerialNumber
+	 -- ^ The most important parameter is the serial number,
+	 -- which must increase after each change.
+	 , sRefresh :: Integer
+	 , sRetry :: Integer
+	 , sExpire :: Integer
+	 , sTTL :: Integer
+	 , sRecord :: [Record]
+	 -- ^ Records for the root of the domain. Typically NS, A, TXT
+	 }
+
+-- | Types of DNS records.
+--
+-- This is not a complete list, more can be added.
+data Record
+	= A Ipv4
+	| AAAA Ipv6
+	| CNAME BindDomain
+	| MX Int BindDomain
+	| NS BindDomain
+	| TXT String
+
+type Ipv4 = String
+type Ipv6 = String
+
+type SerialNumber = Integer
+
+-- | 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 SOADomain refers to the root SOA record.
+data BindDomain = RelDomain Domain | AbsDomain Domain | SOADomain
+
+dValue :: BindDomain -> String
+dValue (RelDomain d) = d
+dValue (AbsDomain d) = d ++ "."
+dValue (SOADomain) = "@"
+
+rField :: Record -> String
+rField (A _) = "A"
+rField (AAAA _) = "AAAA"
+rField (CNAME _) = "CNAME"
+rField (MX _ _) = "MX"
+rField (NS _) = "NS"
+rField (TXT _) = "TXT"
+
+rValue :: Record -> String
+rValue (A addr) = addr
+rValue (AAAA addr) = addr
+rValue (CNAME d) = dValue d
+rValue (MX pri d) = show pri ++ " " ++ dValue d
+rValue (NS d) = dValue d
+rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
+  where
+	q = '\"'
+
+-- | Adjusts the serial number of the zone to 
+--
+-- * Always be larger than the passed SerialNumber
+-- * Always be larger than the serial number in the Zone record.
+nextSerial :: Zone -> SerialNumber -> Zone
+nextSerial (Zone soa l) oldserial = Zone soa' l
+  where
+	soa' = soa { sSerial = succ $ max (sSerial soa) oldserial }
+
+-- | Write a Zone out to a to a file.
+--
+-- The serial number that is written to the file comes from larger of the
+-- Zone's SOA serial number, and the last serial number used in the file.
+-- This ensures that serial number always increases, while also letting
+-- a Zone contain an existing serial number, which may be quite large.
+--
+-- TODO: This increases the serial number when propellor is running on the
+-- same host and generating its zone there, but what if the DNS host is
+-- changed? We'd then want to remember the actual serial number and
+-- propigate it to the new DNS host.
+writeZoneFile :: Zone -> FilePath -> IO ()
+writeZoneFile z f = do
+	oldserial <- nextZoneFileSerialNumber f
+	let z'@(Zone soa' _) = nextSerial z oldserial
+	writeFile f (genZoneFile z')
+	writeFile (zoneSerialFile f) (show $ sSerial soa')
+
+-- | Next to the zone file, is a ".serial" file, which contains
+-- the SOA Serial number of that zone. This saves the bother of parsing
+-- this horrible format.
+zoneSerialFile :: FilePath -> FilePath
+zoneSerialFile f = f ++ ".serial"
+
+nextZoneFileSerialNumber :: FilePath -> IO SerialNumber
+nextZoneFileSerialNumber = maybe 1 (+1) <$$> readZoneSerialFile
+
+readZoneSerialFile :: FilePath -> IO (Maybe SerialNumber)
+readZoneSerialFile f = catchDefaultIO Nothing $
+	readish <$> readFile (zoneSerialFile f)
+
+-- | Generating a zone file.
+genZoneFile :: Zone -> String
+genZoneFile (Zone soa rs) = unlines $
+	header : genSOA soa : map genr rs
+  where
+	header = com "BIND zone file. Generated by propellor, do not edit."
+
+	genr (d, r) = genRecord (Just d, r)
+
+genRecord :: (Maybe Domain, Record) -> String
+genRecord (mdomain, record) = intercalate "\t"
+	[ dname
+	, "IN"
+	, rField record
+	, rValue record
+	]
+  where
+	dname = fromMaybe "" mdomain
+
+genSOA :: SOA -> String
+genSOA soa = unlines $
+	header : map genRecord (zip (repeat Nothing) (sRecord soa))
+  where
+	header = unlines
+		-- @ IN SOA root. root (
+		[ intercalate "\t"
+			[ dValue SOADomain 
+			, "IN"
+			, "SOA"
+			, dValue (sRoot soa)
+			, "root"
+			, "("
+			]
+		, headerline sSerial "Serial"
+		, headerline sRefresh "Refresh"
+		, headerline sRetry "Retry"
+		, headerline sExpire "Expire"
+		, headerline sTTL "Default TTL"
+		, inheader ")"
+		]
+	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
+