ssh connection testing and key setup

1 files changed, 138 insertions, 25 deletions

diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index afd0e1a79..c3d4d9770 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -19,6 +19,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Network.BSD
 import System.Posix.User
+import System.Process (CreateProcess(..))
 
 data SshServer = SshServer
 	{ hostname :: Maybe Text
@@ -56,30 +57,11 @@ data ServerStatus
 	| UsableRsyncServer
 	| UsableSshServer
 
-{- Test if we can ssh into the server. If ssh doesn't work, fall back to
- - trying rsync protocol.
- -
- - Before sshing in, if the user doesn't have a ssh key, a special one is
- - generated just for this server, and configured to be used for this
- - server. (If the user does have a ssh key, we assume they know what
- - they're doing, and don't touch their ssh setup.)
- -
- - If we can ssh in, check that git-annex-shell is installed. If not, this
- - will need to be a rsync special remote, rather than a git remote, so
- - check that rsync is installed.
- -
- - When we ssh in, if we set up a ssh key, the server's authorized_keys
- - is configured to let it run either git-annex-shell or rsync for that ssh
- - key, and nothing else.
- -
- - Of course, ssh may ask for a passphrase, etc. We rely on ssh-askpass
- - or an equivilant being used by ssh. Or, if the assistant is
- - running in the foreground, the password will be asked there.
- -}
-testServer :: SshServer -> IO ServerStatus
-testServer (SshServer { hostname = Nothing }) = return $
-	UnusableServer "Please enter a host name."
-testServer _sshserver = return UsableSshServer
+usable :: ServerStatus -> Bool
+usable UntestedServer = False
+usable (UnusableServer _) = False
+usable UsableRsyncServer = True
+usable UsableSshServer = True
 
 getAddSshR :: Handler RepHtml
 getAddSshR = bootstrap (Just Config) $ do
@@ -91,7 +73,10 @@ getAddSshR = bootstrap (Just Config) $ do
 		runFormGet $ renderBootstrap $ sshServerAForm u
 	case result of
 		FormSuccess sshserver -> do
-			showform form enctype =<< liftIO (testServer sshserver)
+			(status, sshserver') <- liftIO $ testServer sshserver
+			if usable status
+				then error $ "TODO " ++ show sshserver'
+				else showform form enctype status
 		_ -> showform form enctype UntestedServer
 	where
 		showform form enctype status = do
@@ -106,3 +91,131 @@ getAddSshR = bootstrap (Just Config) $ do
 		willTest UntestedServer = True
 		willTest (UnusableServer _) = True
 		willTest _ = False
+
+{- Test if we can ssh into the server.
+ -
+ - Two probe attempts are made. First, try sshing in using the existing
+ - condfiguration, but don't let ssh prompt for any password. If
+ - passwordless login is already enabled, use it. Otherwise,
+ - a special ssh key is generated just for this server, and the server
+ - is configured to allow it.
+ -
+ - If we can ssh in, check that git-annex-shell is installed. If not, this
+ - will need to be a rsync special remote, rather than a git remote, so
+ - check that rsync is installed.
+ -
+ - When ssh asks for a passphrase, we rely on ssh-askpass
+ - or an equivilant being used by ssh. Or, if the assistant is
+ - running in the foreground, the password will be asked there.
+ -}
+testServer :: SshServer -> IO (ServerStatus, SshServer)
+testServer sshserver@(SshServer { hostname = Nothing }) = return
+	(UnusableServer "Please enter a host name.", sshserver)
+testServer sshserver = do
+	home <- myHomeDir
+	let sshdir = home </> ".ssh"
+	status <- probe sshdir sshserver [sshopt "NumberOfPasswordPrompts" "0"] Nothing
+	if usable status
+		then return (status, sshserver)
+		else do
+			(pubkey, sshserver') <- genSshKey sshdir sshserver
+			status' <- probe sshdir sshserver' [] $ Just $ join ";"
+				[ "mkdir -p ~/.ssh"
+				, "touch ~/.ssh/authorized_keys"
+				, "chmod 600 ~/.ssh/authorized_keys"
+				, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
+				]
+			return (status', sshserver')
+	where
+		probe sshdir s extraopts setupcommand = do
+			{- This checks the unmangled server name in sshserver. -}
+			knownhost <- knownHost sshdir sshserver
+			let remotecommand = join ";" $ nonempty
+				[ report "loggedin"
+				, checkcommand "git-annex-shell"
+				, checkcommand "rsync"
+				, fromMaybe "" setupcommand
+				]
+			let user = maybe "" (\u -> T.unpack u ++ "@") $ username s
+			let host = user ++ T.unpack (fromJust $ hostname s)
+			let sshopts = nonempty $ extraopts ++
+				{- If this is an already known host, let
+				 - ssh check it as usual.
+				 - Otherwise, trust the host key. -}
+				[ if knownhost then "" else sshopt "StrictHostKeyChecking" "no"
+				, "-n" -- don't read from stdin
+				, host
+				, remotecommand
+				]
+			parsetranscript <$> sshTranscript sshopts
+		parsetranscript s
+			| reported "git-annex-shell" = UsableSshServer
+			| reported "rsync" = UsableRsyncServer
+			| reported "loggedin" = UnusableServer
+				"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
+			| otherwise = UnusableServer $ T.pack $
+				"Failed to ssh to the server. Transcript: " ++ s
+			where
+				reported r = token r `isInfixOf` s
+		nonempty = filter $ not . null
+		checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
+		token r = "git-annex-probe " ++ r
+		report r = "echo " ++ token r
+		sshopt k v = concat ["-o", k, "=", v]
+
+sshTranscript :: [String] -> IO String
+sshTranscript opts = do
+	(readf, writef) <- createPipe
+	readh <- fdToHandle readf
+	writeh <- fdToHandle writef
+	(_, _, _, pid) <- createProcess $
+		(proc "ssh" opts)
+			{ std_in = Inherit
+			, std_out = UseHandle writeh
+			, std_err = UseHandle writeh
+			}
+	hClose writeh
+	transcript <- hGetContentsStrict readh
+	hClose readh
+	void $ waitForProcess pid
+	return transcript
+
+{- Returns the public key content, and SshServer with a mangled hostname
+ - to use that will enable use of the key. This way we avoid changing the
+ - user's regular ssh experience at all. -}
+genSshKey :: FilePath -> SshServer -> IO (String, SshServer)
+genSshKey _ (SshServer { hostname = Nothing }) = undefined
+genSshKey sshdir sshserver@(SshServer { hostname = Just h }) = do
+	createDirectoryIfMissing True sshdir
+	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
+		unlessM genkey $
+			error "ssh-keygen failed"
+	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
+		appendFile configfile $ unlines
+			[ ""
+			, "# Added automatically by git-annex"
+			, "Host " ++ mangledhost
+			, "\tHostname " ++ T.unpack h
+			, "\tIdentityFile ~/.ssh/" ++ sshprivkeyfile
+			]
+	pubkey <- readFile $ sshdir </> sshpubkeyfile
+	return (pubkey, sshserver { hostname = Just $ T.pack mangledhost })
+	where
+		configfile = sshdir </> "config"
+		sshprivkeyfile = "key." ++ mangledhost
+		sshpubkeyfile = sshprivkeyfile ++ ".pub"
+		mangledhost = "git-annex-" ++ T.unpack h ++ user
+		user = maybe "" (\u -> "-" ++ T.unpack u) (username sshserver)
+		genkey = boolSystem "ssh-keygen"
+			[ Param "-P", Param "" -- no password
+			, Param "-f", File $ sshdir </> sshprivkeyfile
+			]
+
+{- Does ssh have known_hosts data for a hostname? -}
+knownHost :: FilePath -> SshServer -> IO Bool
+knownHost _ (SshServer { hostname = Nothing }) = return False
+knownHost sshdir (SshServer { hostname = Just h }) =
+	ifM (doesFileExist $ sshdir </> "known_hosts")
+		( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h]
+		, return False
+		)