improve ssh user key properties

 * Ssh.keyImported is replaced with Ssh.userKeys. (API change)
   The new property only gets the private key from the privdata; the
   public key is provided as a parameter, and so is available as
   Info that other properties can use.
 * Ssh.keyImported' is renamed to Ssh.userKeyAt, and also changed
   to only import the private key from the privdata. (API change)
 * While Ssh.keyImported and Ssh.keyImported' avoided updating existing
   keys, the new Ssh.userKeys and Ssh.userKeyAt properties will
   always update out of date key files.
 * Ssh.pubKey renamed to Ssh.hostPubKey. (API change)

This makes eg, setting up ssh for spin controllers work better.

1 files changed, 133 insertions, 83 deletions

diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 4450dd07..cdfa36b0 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,7 +1,10 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module Propellor.Property.Ssh (
+	installed,
+	restarted,
 	PubKeyText,
+	-- * Daemon configuration
 	sshdConfig,
 	ConfigKeyword,
 	setSshdConfigBool,
@@ -10,33 +13,42 @@ module Propellor.Property.Ssh (
 	permitRootLogin,
 	passwordAuthentication,
 	noPasswords,
-	hasAuthorizedKeys,
-	authorizedKey,
-	restarted,
+	listenPort,
+	-- * Host keys
 	randomHostKeys,
 	hostKeys,
 	hostKey,
-	pubKey,
-	getPubKey,
-	keyImported,
-	keyImported',
+	hostPubKey,
+	getHostPubKey,
+	-- * User keys and configuration
+	userKeys,
+	userKeyAt,
 	knownHost,
+	authorizedKeysFrom,
 	authorizedKeys,
-	listenPort
+	authorizedKey,
+	hasAuthorizedKeys,
+	getUserPubKeys,
 ) where
 
 import Propellor.Base
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Service as Service
+import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.User
 import Propellor.Types.Info
 import Utility.FileMode
 
 import System.PosixCompat
 import qualified Data.Map as M
+import qualified Data.Set as S
 import Data.List
 
-type PubKeyText = String
+installed :: Property NoInfo
+installed = Apt.installed ["ssh"]
+
+restarted :: Property NoInfo
+restarted = Service.restarted "ssh"
 
 sshBool :: Bool -> String
 sshBool True = "yes"
@@ -95,14 +107,26 @@ dotFile f user = do
 	d <- dotDir user
 	return $ d </> f
 
+-- | Makes the ssh server listen on a given port, in addition to any other
+-- ports it is configured to listen on.
+--
+-- Revert to prevent it listening on a particular port.
+listenPort :: Int -> RevertableProperty
+listenPort port = enable <!> disable
+  where
+	portline = "Port " ++ show port
+	enable = sshdConfig `File.containsLine` portline
+		`describe` ("ssh listening on " ++ portline)
+		`onChange` restarted
+	disable = sshdConfig `File.lacksLine` portline
+		`describe` ("ssh not listening on " ++ portline)
+		`onChange` restarted
+
 hasAuthorizedKeys :: User -> IO Bool
 hasAuthorizedKeys = go <=< dotFile "authorized_keys"
   where
 	go f = not . null <$> catchDefaultIO "" (readFile f)
 
-restarted :: Property NoInfo
-restarted = Service.restarted "ssh"
-
 -- | Blows away existing host keys and make new ones.
 -- Useful for systems installed from an image that might reuse host keys.
 -- A flag file is used to only ever do this once.
@@ -118,6 +142,9 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 		ensureProperty $ scriptProperty 
 			[ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
 
+-- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI"
+type PubKeyText = String
+
 -- | Installs the specified list of ssh host keys.
 --
 -- The corresponding private keys come from the privdata.
@@ -146,29 +173,25 @@ hostKeys ctx l = propertyList desc $ catMaybes $
 -- the private key comes from the privdata; 
 hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
 hostKey context keytype pub = combineProperties desc
-	[ pubKey keytype pub
-	, toProp $ property desc $ install writeFile True (lines pub)
+	[ hostPubKey keytype pub
+	, toProp $ property desc $ install File.hasContent True (lines pub)
 	, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
 		property desc $ getkey $
-			install writeFileProtected False . privDataLines
+			install File.hasContentProtected False . privDataLines
 	]
 	`onChange` restarted
   where
 	desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
 	install writer ispub keylines = do
 		let f = keyFile keytype ispub
-		have <- liftIO $ catchDefaultIO "" $ readFileStrict f
-		let want = keyFileContent keylines
-		if have == want
-			then noChange
-			else makeChange $ writer f want
+		ensureProperty $ writer f (keyFileContent keylines)
 	keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
 		("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
 
 -- Make sure that there is a newline at the end;
 -- ssh requires this for some types of private keys.
-keyFileContent :: [String] -> String
-keyFileContent keylines = unlines (keylines ++ [""])
+keyFileContent :: [String] -> [File.Line]
+keyFileContent keylines = keylines ++ [""]
 
 keyFile :: SshKeyType -> Bool -> FilePath
 keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
@@ -178,40 +201,71 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
 -- | Indicates the host key that is used by a Host, but does not actually
 -- configure the host to use it. Normally this does not need to be used;
 -- use 'hostKey' instead.
-pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
-pubKey t = pureInfoProperty "ssh pubkey known" . SshPubKeyInfo . M.singleton t
+hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo
+hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
 
-getPubKey :: Propellor (M.Map SshKeyType PubKeyText)
-getPubKey = fromSshPubKeyInfo <$> askInfo
+getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
+getHostPubKey = fromHostKeyInfo <$> askInfo
 
-newtype SshPubKeyInfo = SshPubKeyInfo 
-	{ fromSshPubKeyInfo :: M.Map SshKeyType PubKeyText }
+newtype HostKeyInfo = HostKeyInfo 
+	{ fromHostKeyInfo :: M.Map SshKeyType PubKeyText }
 	deriving (Eq, Ord, Typeable)
 
-instance IsInfo SshPubKeyInfo where
+instance IsInfo HostKeyInfo where
 	propigateInfo _ = False
 
-instance Monoid SshPubKeyInfo where
-	mempty = SshPubKeyInfo M.empty
-	mappend (SshPubKeyInfo old) (SshPubKeyInfo new) = 
+instance Monoid HostKeyInfo where
+	mempty = HostKeyInfo M.empty
+	mappend (HostKeyInfo old) (HostKeyInfo new) = 
 		-- new first because union prefers values from the first
 		-- parameter when there is a duplicate key
-		SshPubKeyInfo (new `M.union` old)
+		HostKeyInfo (new `M.union` old)
 
--- | Sets up a user with a ssh private key and public key pair from the
--- PrivData.
---
--- If the user already has a private/public key, it is left unchanged.
-keyImported :: IsContext c => SshKeyType -> User -> c -> Property HasInfo
-keyImported = keyImported' Nothing
+userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo
+userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey known for " ++ n) $
+	UserKeyInfo (M.singleton u (S.fromList l))
 
--- | A file can be speficied to write the key to somewhere other than
--- usual. Allows a user to have multiple keys for different roles.
-keyImported' :: IsContext c => Maybe FilePath -> SshKeyType -> User -> c -> Property HasInfo
-keyImported' dest keytype user@(User u) context = combineProperties desc
-	[ installkey (SshPubKey keytype u) (install writeFile ".pub")
-	, installkey (SshPrivKey keytype u) (install writeFileProtected "")
-	]
+getUserPubKeys :: User -> Propellor [(SshKeyType, PubKeyText)]
+getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo
+
+newtype UserKeyInfo = UserKeyInfo
+	{ fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) }
+	deriving (Eq, Ord, Typeable)
+
+instance IsInfo UserKeyInfo where
+	propigateInfo _ = False
+
+instance Monoid UserKeyInfo where
+	mempty = UserKeyInfo M.empty
+	mappend (UserKeyInfo old) (UserKeyInfo new) = 
+		UserKeyInfo (M.unionWith S.union old new)
+
+-- | Sets up a user with the specified public keys, and the corresponding
+-- private keys from the privdata.
+-- 
+-- The public keys are added to the Info, so other properties like
+-- `authorizedKeysFrom` can use them.
+userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
+userKeys user@(User name) context ks = propertyList desc $
+	userPubKeys user ks : map (userKeyAt Nothing user context) ks
+  where
+	desc = unwords
+		[ name
+		, "has ssh key"
+		, "(" ++ unwords (map (fromKeyType . fst) ks) ++ ")"
+		]
+
+-- | Sets up a user with a ssh private key and public key pair
+-- both coming from the PrivData.
+--
+-- A file can be specified to write the key to somewhere other than
+-- the default locations. Allows a user to have multiple keys for
+-- different roles.
+userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo
+userKeyAt dest user@(User u) context (keytype, pubkeytext) =
+	propertyList desc $ props
+		& pubkey
+		& privkey
   where
 	desc = unwords $ catMaybes
 		[ Just u
@@ -219,39 +273,34 @@ keyImported' dest keytype user@(User u) context = combineProperties desc
 		, dest
 		, Just $ "(" ++ fromKeyType keytype ++ ")"
 		]
-	installkey p a = withPrivData p context $ \getkey ->
-		property desc $ getkey a
+	pubkey = property desc $ install File.hasContent ".pub" [pubkeytext]
+	privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> 
+		property desc $ getkey $
+			install File.hasContentProtected "" . privDataLines
 	install writer ext key = do
 		f <- liftIO $ keyfile ext
-		ifM (liftIO $ doesFileExist f)
-			( noChange
-			, ensureProperties
-				[ property desc $ makeChange $ do
-					createDirectoryIfMissing True (takeDirectory f)
-					writer f (keyFileContent (privDataLines key))
-				, File.ownerGroup f user (userGroup user)
-				, File.ownerGroup (takeDirectory f) user (userGroup user)
-				]
-			)
+		ensureProperties
+			[ writer f (keyFileContent key)
+			, File.ownerGroup f user (userGroup user)
+			, File.ownerGroup (takeDirectory f) user (userGroup user)
+			]
 	keyfile ext = case dest of
 		Nothing -> do
 			home <- homeDirectory <$> getUserEntryForName u
 			return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext
 		Just f -> return $ f ++ ext
 
-
-
 fromKeyType :: SshKeyType -> String
 fromKeyType SshRsa = "rsa"
 fromKeyType SshDsa = "dsa"
 fromKeyType SshEcdsa = "ecdsa"
 fromKeyType SshEd25519 = "ed25519"
 
--- | Puts some host's ssh public key(s), as set using 'pubKey' or 'hostKey'
--- into the known_hosts file for a user.
+-- | Puts some host's ssh public key(s), as set using `hostPubKey`
+-- or `hostKey` into the known_hosts file for a user.
 knownHost :: [Host] -> HostName -> User -> Property NoInfo
 knownHost hosts hn user@(User u) = property desc $
-	go =<< fromHost hosts hn getPubKey
+	go =<< fromHost hosts hn getHostPubKey
   where
 	desc = u ++ " knows ssh key for " ++ hn
 	go (Just m) | not (M.null m) = do
@@ -264,8 +313,26 @@ knownHost hosts hn user@(User u) = property desc $
 			, File.ownerGroup (takeDirectory f) user (userGroup user)
 			]
 	go _ = do
-		warningMessage $ "no configred pubKey for " ++ hn
+		warningMessage $ "no configured ssh host keys for " ++ hn
+		return FailedChange
+
+-- | Ensures that a local user's authorized keys contains a line allowing
+-- logins from a remote user on the specified Host.
+--
+-- The ssh keys of the remote user can be set using `keysImported`
+--
+-- Any other lines in the authorized_keys file are preserved as-is.
+authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = 
+	property desc $ go =<< fromHost' remotehost (getUserPubKeys remoteuser)
+  where
+	remote = rn ++ "@" ++ hostName remotehost
+	desc = ln ++ " authorized_keys from " ++ remote
+	go [] = do
+		warningMessage $ "no configured ssh user keys for " ++ remote
 		return FailedChange
+	go ks = ensureProperty $ propertyList desc $
+		map (authorizedKey localuser . snd) ks
 
 -- | Makes a user have authorized_keys from the PrivData
 --
@@ -274,11 +341,9 @@ authorizedKeys :: IsContext c => User -> c -> Property HasInfo
 authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get ->
 	property (u ++ " has authorized_keys") $ get $ \v -> do
 		f <- liftIO $ dotFile "authorized_keys" user
-		liftIO $ do
-			createDirectoryIfMissing True (takeDirectory f)
-			writeFileProtected f (keyFileContent (privDataLines v))
 		ensureProperties 
-			[ File.ownerGroup f user (userGroup user)
+			[ File.hasContentProtected f (keyFileContent (privDataLines v))
+			, File.ownerGroup f user (userGroup user)
 			, File.ownerGroup (takeDirectory f) user (userGroup user)
 			] 
 
@@ -296,18 +361,3 @@ authorizedKey user@(User u) l = property desc $ do
 		]
   where
 	desc = u ++ " has autorized_keys"
-
--- | Makes the ssh server listen on a given port, in addition to any other
--- ports it is configured to listen on.
---
--- Revert to prevent it listening on a particular port.
-listenPort :: Int -> RevertableProperty
-listenPort port = enable <!> disable
-  where
-	portline = "Port " ++ show port
-	enable = sshdConfig `File.containsLine` portline
-		`describe` ("ssh listening on " ++ portline)
-		`onChange` restarted
-	disable = sshdConfig `File.lacksLine` portline
-		`describe` ("ssh not listening on " ++ portline)
-		`onChange` restarted