Merge branch 'joeyconfig'

Conflicts:
	privdata.joey/privdata.gpg

6 files changed, 64 insertions, 19 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..7b1fbcc5 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
@@ -38,6 +39,9 @@ import Data.List
 -- Will cause that hostmame and its alias to appear in the zone file,
 -- with the configured IP address.
 --
+-- Also, if a host has a ssh public key configured, a SSHFP record will
+-- be automatically generated for it.
+--
 -- The [(BindDomain, Record)] list can be used for additional records
 -- that cannot be configured elsewhere. This often includes NS records,
 -- TXT records and perhaps CNAMEs pointing at hosts that propellor does
@@ -65,17 +69,27 @@ 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 <- 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 +106,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 +292,7 @@ rField (MX _ _) = "MX"
 rField (NS _) = "NS"
 rField (TXT _) = "TXT"
 rField (SRV _ _ _ _) = "SRV"
+rField (SSHFP _ _ _) = "SSHFP"
 rField (INCLUDE _) = "$INCLUDE"
 
 rValue :: Record -> String
@@ -292,6 +307,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 +417,44 @@ 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 [(BindDomain, Record)]
+genSSHFP h = map (\r -> (AbsDomain hostname, r)) . concat <$> (gen =<< get)
+  where
+	hostname = hostName h
+	get = fromHost [h] hostname Ssh.getPubKey
+	gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
+
+genSSHFP' :: String -> IO [Record]
+genSSHFP' 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
+  where
+	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/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index f45a4aa8..84c8a787 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -3,7 +3,6 @@ module Propellor.Property.HostingProvider.CloudAtCost where
 import Propellor
 import qualified Propellor.Property.Hostname as Hostname
 import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Ssh as Ssh
 import qualified Propellor.Property.User as User
 
 -- Clean up a system as installed by cloudatcost.com
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index b6ed476e..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,
@@ -120,7 +121,7 @@ hostKey context keytype pub = combineProperties desc
 	desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
 	install writer ispub key = do
 		let f = keyFile keytype ispub
-		s <- liftIO $ readFileStrict f
+		s <- liftIO $ catchDefaultIO "" $ readFileStrict f
 		if s == key
 			then noChange
 			else makeChange $ writer f key
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)
 
diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs
index c760ae55..c7909a6b 100644
--- a/src/Propellor/Types/PrivData.hs
+++ b/src/Propellor/Types/PrivData.hs
@@ -7,8 +7,8 @@ import Propellor.Types.OS
 -- It's fine to add new constructors.
 data PrivDataField
 	= DockerAuthentication
-	| SshPubKey SshKeyType UserName -- ^ For host key, use empty UserName
-	| SshPrivKey SshKeyType UserName
+	| SshPubKey SshKeyType UserName
+	| SshPrivKey SshKeyType UserName -- ^ For host key, use empty UserName
 	| SshAuthorizedKeys UserName
 	| Password UserName
 	| CryptPassword UserName