propellor/Propellor/Property/Dns.hs

module Propellor.Property.Dns where

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
import Data.Time.Clock.POSIX
import Data.Time.Format
import Foreign.C.Types

namedconf :: FilePath
namedconf = "/etc/bind/named.conf.local"

data NamedConf = NamedConf
	{ zdomain :: Domain
	, ztype :: Type
	, zfile :: FilePath
	, zmasters :: [IPAddr]
	, zconfiglines :: [String]
	}

zoneDesc :: NamedConf -> String
zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"

type IPAddr = String

type Domain = String

data Type = Master | Secondary
	deriving (Show, Eq)

secondary :: Domain -> [IPAddr] -> NamedConf
secondary domain masters = NamedConf
	{ zdomain = domain
	, ztype = Secondary
	, zfile = "db." ++ domain
	, zmasters = masters
	, zconfiglines = ["allow-transfer { }"]
	}

zoneStanza :: NamedConf -> [Line]
zoneStanza z =
	[ "// automatically generated by propellor"
	, "zone \"" ++ zdomain z ++ "\" {"
	, cfgline "type" (if ztype z == Master then "master" else "slave")
	, cfgline "file" ("\"" ++ zfile z ++ "\"")
	] ++
	(if null (zmasters z) then [] else mastersblock) ++
	(map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++
	[ "};"
	, ""
	]
  where
	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
	mastersblock =
		[ "\tmasters {" ] ++
		(map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++
		[ "\t};" ]

-- | Rewrites the whole named.conf.local file to serve the specificed
-- zones.
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
	{ zSOA :: SOA
	, zHosts :: [(HostName, 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
	, sTTL :: Integer
	, sRecord :: [Record]
	-- ^ Records for the root of the domain. Typically NS, A, TXT
	}
	deriving (Read, Show, Eq)

-- |  Generates a SOA with some fairly sane numbers in it.
mkSOA :: Domain -> [Record] -> SOA
mkSOA d rs = SOA
	{ sDomain = AbsDomain d
	, sSerial = 1
	, sRefresh = hours 4
	, sRetry = hours 1
	, sExpire = 2419200 -- 4 weeks
	, sTTL = hours 8
	, sRecord = rs
	}
  where
	hours n = n * 60 * 60

-- | 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
	deriving (Read, Show, Eq)

type Ipv4 = String
type Ipv6 = String

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

-- | 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
	deriving (Read, Show, Eq)

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.
nextSerialNumber :: Zone -> SerialNumber -> Zone
nextSerialNumber (Zone soa l) oldserial = Zone soa' l
  where
	soa' = soa { sSerial = succ $ max (sSerial soa) oldserial }

incrSerialNumber :: Zone -> Zone
incrSerialNumber (Zone soa l) = Zone soa' l
  where
	soa' = soa { sSerial = succ (sSerial soa) }

-- | Propellor uses a serial number derived from the current date and time.
--
-- This ensures that, even if zone files are being generated on
-- multiple hosts, the serial numbers will not get out of sync between
-- them.
--
-- Since serial numbers are limited to 32 bits, the number of seconds
-- since the epoch is divided by 5. This will work until the year 2650,
-- at which point this stupid limit had better have been increased to
-- 128 bits. If we didn't divide by 5, it would only work up to 2106!
--
-- Dividing by 5 means that this number only changes once every 5 seconds.
-- If propellor is running more often than once every 5 seconds, you're
-- doing something wrong.
currentSerialNumber :: IO SerialNumber
currentSerialNumber = calc <$> getPOSIXTime
  where
	calc t = floor (t / 5)

-- | 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.
writeZoneFile :: Zone -> FilePath -> IO ()
writeZoneFile z f = do
	oldserial <- nextZoneFileSerialNumber f
	let z' = nextSerialNumber z oldserial
	writeFile f (genZoneFile z')
	writeZonePropellorFile f z'

-- | 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 ++ ".serial"

nextZoneFileSerialNumber :: FilePath -> IO SerialNumber
nextZoneFileSerialNumber = maybe 1 (sSerial . zSOA . incrSerialNumber)
	<$$> readZonePropellorFile

writeZonePropellorFile :: FilePath -> Zone -> IO ()
writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)

readZonePropellorFile :: FilePath -> IO (Maybe Zone)
readZonePropellorFile f = catchDefaultIO Nothing $
	readish <$> readFile (zonePropellorFile 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 (sDomain 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