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 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 :: [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 ->
let oldserial = sSerial(zSOA oldzone)
z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }
in z /= oldzone || oldserial < sSerial (zSOA zone)
secondary :: [Host] -> Domain -> RevertableProperty
secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
secondaryFor masters hosts domain = RevertableProperty setup cleanup
where
setup = pureInfoProperty 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 $ hostMap hosts
where
wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
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)
allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)
namedConfFile :: FilePath
namedConfFile = "/etc/bind/named.conf.local"
mkSOA :: Domain -> SerialNumber -> SOA
mkSOA d sn = SOA
{ sDomain = AbsDomain d
, sSerial = sn
, sRefresh = hours 4
, sRetry = hours 1
, sExpire = 2419200
, 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 = '"'
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) }
serialNumberOffset :: IO SerialNumber
serialNumberOffset = fromIntegral . length . lines
<$> readProcess "git" ["log", "--pretty=%H"]
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)
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)
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 =
[ 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
com :: String -> String
com s = "; " ++ s
type WarningMessage = String
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 (simplify zhosts), warnings)
where
m = hostMap hosts
inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m
hostips :: Host -> [Either WarningMessage (BindDomain, Record)]
hostips h
| null l = [Left $ "no IP address defined for host " ++ hostName h]
| otherwise = map Right l
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
(map Address $ getAddresses info)
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
mapMaybe getCNAME $ S.toList (_dns info)
where
info = hostInfo h
gen c = case getAddresses info of
[] -> [ret (CNAME c)]
l -> map (ret . Address) l
where
ret record = Right (c, record)
hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)]
hostrecords h = map Right l
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info))
simplify :: [(BindDomain, Record)] -> [(BindDomain, Record)]
simplify l = nub $ filter (not . dupcname ) l
where
dupcname (d, CNAME _) | any (matchingaddr d) l = True
dupcname _ = False
matchingaddr d (d', (Address _)) | d == d' = True
matchingaddr _ _ = False
inDomain :: Domain -> BindDomain -> Bool
inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d
inDomain _ _ = False
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
addNamedConf :: NamedConf -> Info
addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) }
where
domain = confDomain conf
getNamedConf :: Propellor (M.Map Domain NamedConf)
getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo