From 8e442f0656365e48565547b5d6b45f0c42ae320f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 4 Jan 2015 19:24:18 -0400 Subject: DNS records for hosts with known ssh public keys now automatically include SSHFP records. --- src/Propellor/Info.hs | 1 + src/Propellor/Property/Dns.hs | 67 +++++++++++++++++++++++++++++++++---------- src/Propellor/Property/Ssh.hs | 1 + src/Propellor/Types/Dns.hs | 1 + 4 files changed, 55 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index b7ca81b5..ccb27cf3 100644 --- a/src/Propellor/Info.hs +++ b/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 diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 581a9bfe..b85c7158 100644 --- a/src/Propellor/Property/Dns.hs +++ b/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. -- diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index e8671a22..238e67e4 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -9,6 +9,7 @@ module Propellor.Property.Ssh ( hostKeys, hostKey, pubKey, + getPubKey, keyImported, knownHost, authorizedKeys, diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 2fbf51e5..50297f57 100644 --- a/src/Propellor/Types/Dns.hs +++ b/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) -- cgit v1.2.3