summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2015-01-04 19:24:18 -0400
committerJoey Hess2015-01-04 19:24:18 -0400
commit8e442f0656365e48565547b5d6b45f0c42ae320f (patch)
treebdd7252833db4e8443c4ed1de54df64691fa2d7d /src/Propellor
parent302fb3183fc60cbd3fd6dcca21257df11e3bae59 (diff)
DNS records for hosts with known ssh public keys now automatically include SSHFP records.
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Info.hs1
-rw-r--r--src/Propellor/Property/Dns.hs67
-rw-r--r--src/Propellor/Property/Ssh.hs1
-rw-r--r--src/Propellor/Types/Dns.hs1
4 files changed, 55 insertions, 15 deletions
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)