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 :: [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, warnings) = 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 warnings
satisfy
conf = NamedConf
{ confDomain = domain
, confType = Master
, confFile = zonefile
, confMasters = []
, confLines = []
}
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 masters hosts domain
where
masters = M.keys $ M.filter ismaster $ hostAttrMap hosts
ismaster attr = case M.lookup domain (_namedconf attr) of
Nothing -> False
Just conf -> confType conf == Master && confDomain conf == domain
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
, confType = Secondary
, confFile = "db." ++ domain
, confMasters = concatMap (\m -> hostAddresses m hosts) masters
, confLines = ["allow-transfer { }"]
}
servingZones :: Property
servingZones = namedConfWritten
`requires` Apt.serviceInstalledRunning "bind9"
`onChange` Service.reloaded "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 confType c == Master then "master" else "slave")
, cfgline "file" ("\"" ++ confFile c ++ "\"")
] ++
(if null (confMasters c) then [] else mastersblock) ++
(map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
[ "};"
, ""
]
where
cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
mastersblock =
[ "\tmasters {" ] ++
(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") (confMasters c)) ++
[ "\t};" ]
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 (nub zhosts), warnings)
where
m = hostAttrMap hosts
inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m
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)
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)
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
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