DNS records for hosts with known ssh public keys now automatically include SSHFP records.

debian/changelog

@@ -2,6 +2,8 @@ propellor (1.3.1) UNRELEASED; urgency=medium
 
   * Fix bug that prevented deploying ssh host keys when the file for the
     key didn't already exist.
+  * DNS records for hosts with known ssh public keys now automatically
+    include SSHFP records.
 
  -- Joey Hess <id@joeyh.name>  Sun, 04 Jan 2015 18:19:30 -0400
 

src/Propellor/Info.hs

@@ -64,6 +64,7 @@ addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
 	rdesc (NS d) = unwords ["NS", ddesc d]
 	rdesc (TXT s) = unwords ["TXT", s]
 	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
+	rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s]
 	rdesc (INCLUDE f) = unwords ["$INCLUDE", f]
 
 	ddesc (AbsDomain domain) = domain

src/Propellor/Property/Dns.hs

@@ -17,6 +17,7 @@ import Propellor
 import Propellor.Types.Dns
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Ssh as Ssh
 import qualified Propellor.Property.Service as Service
 import Propellor.Property.Scheduled
 import Propellor.Property.DnsSec
@@ -65,17 +66,28 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
 
 setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property
 setupPrimary zonefile mknamedconffile hosts domain soa rs = 
-	withwarnings (check needupdate baseprop)
+	withwarnings baseprop
 		`requires` servingZones
   where
-	(partialzone, zonewarnings) = genZone hosts domain soa
-	zone = partialzone { zHosts = zHosts partialzone ++ rs }
-	baseprop = Property ("dns primary for " ++ domain)
-		(makeChange $ writeZoneFile zone zonefile)
+	hostmap = hostMap hosts
+	-- Known hosts with hostname located in the domain.
+	indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
+	
+	(partialzone, zonewarnings) = genZone indomain hostmap domain soa
+	baseprop = Property ("dns primary for " ++ domain) satisfy
 		(addNamedConf conf)
-	withwarnings p = adjustProperty p $ \satisfy -> do
+	satisfy = do
+		sshfps <- zip (repeat (AbsDomain domain)) . concat
+			<$> mapM genSSHFP indomain
+		let zone = partialzone
+			{ zHosts = zHosts partialzone ++ rs ++ sshfps }
+		ifM (liftIO $ needupdate zone)
+			( makeChange $ writeZoneFile zone zonefile
+			, noChange
+			)
+	withwarnings p = adjustProperty p $ \a -> do
 		mapM_ warningMessage $ zonewarnings ++ secondarywarnings
-		satisfy
+		a
 	conf = NamedConf
 		{ confDomain = domain
 		, confDnsServerType = Master
@@ -92,7 +104,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 	nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords
 	rootRecords = map snd $
 		filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs
-	needupdate = do
+	needupdate zone = do
 		v <- readZonePropellorFile zonefile
 		return $ case v of
 			Nothing -> True
@@ -278,6 +290,7 @@ rField (MX _ _) = "MX"
 rField (NS _) = "NS"
 rField (TXT _) = "TXT"
 rField (SRV _ _ _ _) = "SRV"
+rField (SSHFP _ _ _) = "SSHFP"
 rField (INCLUDE _) = "$INCLUDE"
 
 rValue :: Record -> String
@@ -292,6 +305,11 @@ rValue (SRV priority weight port target) = unwords
 	, show port
 	, dValue target
 	]
+rValue (SSHFP x y s) = unwords
+	[ show x
+	, show y
+	, s
+	]
 rValue (INCLUDE f) = f
 rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
   where
@@ -397,21 +415,40 @@ com s = "; " ++ s
 
 type WarningMessage = String
 
+-- | Generates SSHFP records for hosts that have configured
+-- ssh public keys.
+--
+-- This is done using ssh-keygen, so sadly needs IO.
+genSSHFP :: Host -> Propellor [Record]
+genSSHFP h = concat <$> (gen =<< get)
+  where
+	get =  fromHost [h] (hostName h) Ssh.getPubKey
+	gen = liftIO . mapM go . M.elems . fromMaybe M.empty
+	go pubkey = withTmpFile "sshfp" $ \tmp tmph -> do
+		hPutStrLn tmph pubkey
+		hClose tmph
+		s <- catchDefaultIO "" $
+			readProcess "ssh-keygen" ["-r", "dummy", "-f", tmp]
+		return $ mapMaybe (parse . words) $ lines s
+	parse ("dummy":"IN":"SSHFP":x:y:s:[]) = do
+		x' <- readish x
+		y' <- readish y
+		return $ SSHFP x' y' s
+	parse _ = Nothing
+
 -- | 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 =
+--
+-- Does not include SSHFP records.
+genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage])
+genZone inzdomain hostmap zdomain soa =
 	let (warnings, zhosts) = partitionEithers $ concat $ map concat
 		[ map hostips inzdomain
 		, map hostrecords inzdomain
-		, map addcnames (M.elems m)
+		, map addcnames (M.elems hostmap)
 		]
 	in (Zone zdomain soa (simplify zhosts), warnings)
   where
-	m = hostMap 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 Info.
 	--

src/Propellor/Property/Ssh.hs

@@ -9,6 +9,7 @@ module Propellor.Property.Ssh (
 	hostKeys,
 	hostKey,
 	pubKey,
+	getPubKey,
 	keyImported,
 	knownHost,
 	authorizedKeys,

src/Propellor/Types/Dns.hs

@@ -62,6 +62,7 @@ data Record
 	| NS BindDomain
 	| TXT String
 	| SRV Word16 Word16 Word16 BindDomain
+	| SSHFP Int Int String
 	| INCLUDE FilePath
 	deriving (Read, Show, Eq, Ord)