assistant: Fix local pairing when ssh pubkey comment contains spaces.

2 files changed, 15 insertions, 24 deletions

diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index 8c0c4d524..05533e270 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -23,12 +23,11 @@ import qualified Data.Text as T
 {- Authorized keys are set up before pairing is complete, so that the other
  - side can immediately begin syncing. -}
 setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
-setupAuthorizedKeys msg repodir = do
-	validateSshPubKey pubkey
-	unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
-		error "failed setting up ssh authorized keys"
-  where
-	pubkey = remoteSshPubKey $ pairMsgData msg
+setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
+	Left err -> error err
+	Right pubkey -> 
+		unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
+			error "failed setting up ssh authorized keys"
 
 {- When local pairing is complete, this is used to set up the remote for
  - the host we paired with. -}
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index c41340962..88afec713 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -111,34 +111,26 @@ sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
 sshTranscript opts input = processTranscript "ssh" opts input
 
 {- Ensure that the ssh public key doesn't include any ssh options, like
- - command=foo, or other weirdness -}
-validateSshPubKey :: SshPubKey -> IO ()
+ - command=foo, or other weirdness.
+ -
+ - The returned version of the key has its comment removed.
+ -}
+validateSshPubKey :: SshPubKey -> Either String SshPubKey
 validateSshPubKey pubkey
-	| length (lines pubkey) == 1 =
-		either error return $ check $ words pubkey
-	| otherwise = error "too many lines in ssh public key"
+	| length (lines pubkey) == 1 = check $ words pubkey
+	| otherwise = Left "too many lines in ssh public key"
   where
-	check [prefix, _key, comment] = do
-		checkprefix prefix
-		checkcomment comment
-	check [prefix, _key] =
-		checkprefix prefix
+	check (prefix:key:_) = checkprefix prefix (unwords [prefix, key])
 	check _ = err "wrong number of words in ssh public key"
 
-	ok = Right ()
 	err msg = Left $ unwords [msg, pubkey]
 
-	checkprefix prefix
-		| ssh == "ssh" && all isAlphaNum keytype = ok
+	checkprefix prefix validpubkey
+		| ssh == "ssh" && all isAlphaNum keytype = Right validpubkey
 		| otherwise = err "bad ssh public key prefix"
 	  where
 		(ssh, keytype) = separate (== '-') prefix
 
-	checkcomment comment = case filter (not . safeincomment) comment of
-		[] -> ok
-		badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
-	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
-
 addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
 addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
 	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]