assistant: Set StrictHostKeyChecking yes when creating ssh remotes, and add it to the configuration for any ssh remotes previously created by the assistant. This avoids repeated prompts by ssh if the host key changes, instead syncing with such a remote will fail. Closes: #732602

6 files changed, 180 insertions, 22 deletions

diff --git a/Assistant/Install.hs b/Assistant/Install.hs
index bb8053ffa..2b6297b1f 100644
--- a/Assistant/Install.hs
+++ b/Assistant/Install.hs
@@ -11,12 +11,12 @@ module Assistant.Install where
 
 import Assistant.Common
 import Assistant.Install.AutoStart
-import Assistant.Ssh
 import Config.Files
 import Utility.FileMode
 import Utility.Shell
 import Utility.Tmp
 import Utility.Env
+import Utility.SshConfig
 
 #ifdef darwin_HOST_OS
 import Utility.OSX
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 1dc982ba6..d69c29254 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -9,10 +9,10 @@ module Assistant.Ssh where
 
 import Common.Annex
 import Utility.Tmp
-import Utility.UserInfo
 import Utility.Shell
 import Utility.Rsync
 import Utility.FileMode
+import Utility.SshConfig
 import Git.Remote
 
 import Data.Text (Text)
@@ -54,11 +54,6 @@ type SshPubKey = String
 sshOpt :: String -> String -> String
 sshOpt k v = concat ["-o", k, "=", v]
 
-sshDir :: IO FilePath
-sshDir = do
-	home <- myHomeDir
-	return $ home </> ".ssh"
-
 {- user@host or host -}
 genSshHost :: Text -> Maybe Text -> String
 genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
@@ -228,6 +223,10 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
  -
  - Similarly, IdentitiesOnly is set in the ssh config to prevent the
  - ssh-agent from forcing use of a different key.
+ -
+ - Force strict host key checking to avoid repeated prompts
+ - when git-annex and git try to access the remote, if its
+ - host key has changed.
  -}
 setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
 setupSshKeyPair sshkeypair sshdata = do
@@ -242,29 +241,22 @@ setupSshKeyPair sshkeypair sshdata = do
 	setSshConfig sshdata
 		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
 		, ("IdentitiesOnly", "yes")
+		, ("StrictHostKeyChecking", "yes")
 		]
   where
 	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
 	sshpubkeyfile = sshprivkeyfile ++ ".pub"
 
 {- Fixes git-annex ssh key pairs configured in .ssh/config 
- - by old versions to set IdentitiesOnly. -}
-fixSshKeyPair :: IO ()
-fixSshKeyPair = do
-	sshdir <- sshDir
-	let configfile = sshdir </> "config"
-	whenM (doesFileExist configfile) $ do
-		ls <- lines <$> readFileStrict configfile
-		let ls' = fixSshKeyPair' ls
-		when (ls /= ls') $
-			viaTmp writeFile configfile $ unlines ls'
-
-{- Strategy: Search for IdentityFile lines in for files with key.git-annex
+ - by old versions to set IdentitiesOnly.
+ -
+ - Strategy: Search for IdentityFile lines with key.git-annex
  - in their names. These are for git-annex ssh key pairs.
  - Add the IdentitiesOnly line immediately after them, if not already
- - present. -}
-fixSshKeyPair' :: [String] -> [String]
-fixSshKeyPair' = go []
+ - present.
+ -}
+fixSshKeyPairIdentitiesOnly :: IO ()
+fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
   where
   	go c [] = reverse c
 	go c (l:[])
@@ -277,6 +269,20 @@ fixSshKeyPair' = go []
   	indicators = ["IdentityFile", "key.git-annex"]
 	fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
 
+{- Add StrictHostKeyChecking to any ssh config stanzas that were written
+ - by git-annex. -}
+fixUpSshRemotes :: IO ()
+fixUpSshRemotes = modifyUserSshConfig (map go)
+  where
+	go c@(HostConfig h _)
+		| "git-annex-" `isPrefixOf` h = fixupconfig c
+		| otherwise = c
+	go other = other
+
+	fixupconfig c = case findHostConfigKey c "StrictHostKeyChecking" of
+		Nothing -> addToHostConfig c "StrictHostKeyChecking" "yes"
+		Just _ -> c
+
 {- Setups up a ssh config with a mangled hostname.
  - Returns a modified SshData containing the mangled hostname. -}
 setSshConfig :: SshData -> [(String, String)] -> IO SshData
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 2e6a28759..446ade54f 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -15,6 +15,7 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.Repair
+import Assistant.Ssh
 import qualified Git.LsFiles
 import qualified Git.Command
 import qualified Git.Config
@@ -53,6 +54,9 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 			modifyDaemonStatus_ $ \s -> s { forceRestage = True }
 		)
 
+	{- Fix up ssh remotes set up by past versions of the assistant. -}
+	liftIO $ fixUpSshRemotes
+
 	{- If there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 
diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs
new file mode 100644
index 000000000..b7068f48d
--- /dev/null
+++ b/Utility/SshConfig.hs
@@ -0,0 +1,125 @@
+{- ssh config file parsing and modification
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.SshConfig where
+
+import Common
+import Utility.UserInfo
+import Utility.Tmp
+
+import Data.Char
+import Data.Ord
+import Data.Either
+
+data SshConfig
+	= GlobalConfig SshSetting
+	| HostConfig Host [Either Comment SshSetting]
+	| CommentLine Comment
+	deriving (Show)
+
+data Comment = Comment Indent String
+	deriving (Show)
+
+data SshSetting = SshSetting Indent Key Value
+	deriving (Show)
+
+type Indent = String
+type Host = String
+type Key = String
+type Value = String
+
+{- Parses ~/.ssh/config. Comments and indentation are preserved.
+ -
+ - Note that there is no parse failure. If a line cannot be parsed, it will
+ - be taken to be a SshSetting that contains the whole line as the key,
+ - and has no value. -}
+parseSshConfig :: String -> [SshConfig]
+parseSshConfig = go [] . lines
+  where
+	go c [] = reverse c
+	go c (l:ls)
+		| iscomment l = collect $ CommentLine $ mkcomment l
+		| otherwise = case splitline l of
+			(indent, k, v)
+				| isHost k -> hoststanza v c [] ls
+				| otherwise -> collect $ GlobalConfig $ SshSetting indent k v
+	  where
+		collect v = go (v:c) ls
+
+	hoststanza host c hc [] = go (HostConfig host (reverse hc):c) []
+	hoststanza host c hc (l:ls)
+		| iscomment l = hoststanza host c ((Left $ mkcomment l):hc) ls
+		| otherwise = case splitline l of
+			(indent, k, v)
+			 	| isHost k -> hoststanza v
+					(HostConfig host (reverse hc):c) [] ls
+				| otherwise -> hoststanza host c
+					((Right $ SshSetting indent k v):hc) ls
+
+	iscomment l = all isSpace l || "#" `isPrefixOf` (dropWhile isSpace l)
+
+	splitline l = (indent, k, v)
+	  where
+		(indent, rest) = span isSpace l
+		(k, v) = separate isSpace rest
+	
+	mkcomment l = Comment indent c
+	  where
+		(indent, c) = span isSpace l
+
+	isHost v = map toLower v == "host"
+	
+genSshConfig :: [SshConfig] -> String
+genSshConfig = unlines . concatMap gen
+  where
+	gen (CommentLine c) = [comment c]
+	gen (GlobalConfig s) = [setting s]
+	gen (HostConfig h cs) = ("Host " ++ h) : map (either comment setting) cs
+
+	setting (SshSetting indent k v) = indent ++ k ++ " " ++ v
+	comment (Comment indent c) = indent ++ c
+
+findHostConfigKey :: SshConfig -> Key -> Maybe Value
+findHostConfigKey (HostConfig _ cs) wantk = go (rights cs) (map toLower wantk)
+  where
+  	go [] _ = Nothing
+	go ((SshSetting _ k v):rest) wantk'
+		| map toLower k == wantk' = Just v
+		| otherwise = go rest wantk'
+findHostConfigKey _ _ = Nothing
+
+{- Adds a particular Key and Value to a HostConfig. -}
+addToHostConfig :: SshConfig -> Key -> Value -> SshConfig
+addToHostConfig (HostConfig host cs) k v = 
+	HostConfig host $ Right (SshSetting indent k v) : cs
+  where
+ 	{- The indent is taken from any existing SshSetting
+	 - in the HostConfig (largest indent wins). -}
+	indent = fromMaybe "\t" $ headMaybe $ reverse $
+		sortBy (comparing length) $ map getindent cs
+	getindent (Right (SshSetting i _ _)) = i
+	getindent (Left (Comment i _)) = i
+addToHostConfig other _ _ = other
+
+modifyUserSshConfig :: ([SshConfig] -> [SshConfig]) -> IO ()
+modifyUserSshConfig modifier = changeUserSshConfig $ 
+	genSshConfig . modifier . parseSshConfig
+
+changeUserSshConfig :: (String -> String) -> IO ()
+changeUserSshConfig modifier = do
+	sshdir <- sshDir
+	let configfile = sshdir </> "config"
+	whenM (doesFileExist configfile) $ do
+		c <- readFileStrict configfile
+		let c' = modifier c
+		when (c /= c') $
+			viaTmp writeFile configfile c'
+
+sshDir :: IO FilePath
+sshDir = do
+	home <- myHomeDir
+	return $ home </> ".ssh"
diff --git a/debian/changelog b/debian/changelog
index afdc51038..04dd79fe0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -13,6 +13,10 @@ git-annex (5.20131214) UNRELEASED; urgency=low
   * assistant: Always batch changes found in startup scan.
   * assistant: Fix OSX-specific bug that caused the startup scan to try to
     follow symlinks to other directories, and add their contents to the annex.
+  * assistant: Set StrictHostKeyChecking yes when creating ssh remotes,
+    and add it to the configuration for any ssh remotes previously created
+    by the assistant. This avoids repeated prompts by ssh if the host key
+    changes, instead syncing with such a remote will fail. Closes: #732602
 
  -- Joey Hess <joeyh@debian.org>  Sun, 15 Dec 2013 13:32:49 -0400
 
diff --git a/doc/bugs/Endless_SSH_password_prompts.mdwn b/doc/bugs/Endless_SSH_password_prompts.mdwn
index 26def613f..fad730a1b 100644
--- a/doc/bugs/Endless_SSH_password_prompts.mdwn
+++ b/doc/bugs/Endless_SSH_password_prompts.mdwn
@@ -13,3 +13,22 @@ I don't understand why this is happening.
 
 ### What version of git-annex are you using? On what operating system?
 1 Nov 2013 Linux tarball on Ubuntu Raring 13.04
+
+> [[fixed|done]]; assistant now sets `StrictHostKeyChecking yes`
+> when creating ssh remotes. It also fixes up any ssh remotes it already
+> created to have that setting (unless StrictHostKeyChecking is already
+> being set).
+> 
+> So, when the host key changes, syncing with the remote will now fail,
+> rather than letting ssh prompt for the y/n response. In the local
+> pairing case, this is completely right, when on a different lan
+> and it tries to communicate with the wrong host there. OTOH, if the ssh
+> key of a ssh server has really changed, the assistant does not currently
+> help dealing with that.
+> 
+> Any ssh remotes not set up by the assistant are left as-is, so this 
+> could still happen if the ssh host key of such a ssh remote changes.
+> I'll assume that if someone can set up their ssh remotes at the command
+> line, they can also read the dialog box ssh pops up, ignore the 
+> misleading "passphrase request" in the title, and see that it's actually
+> prompting about a host key change. --[[Joey]]