webapp: Allow user to specify the ssh port when setting up a remote.

Assistant/Pairing/MakeRemote.hs

@@ -60,6 +60,7 @@ pairMsgToSshData msg = do
 		, sshUserName = Just (T.pack $ remoteUserName d)
 		, sshDirectory = T.pack dir
 		, sshRepoName = genSshRepoName hostname dir
+		, sshPort = 22
 		, needsPubKey = True
 		, rsyncOnly = False
 		}

Assistant/Ssh.hs

@@ -24,6 +24,7 @@ data SshData = SshData
 	, sshUserName :: Maybe Text
 	, sshDirectory :: Text
 	, sshRepoName :: String
+	, sshPort :: Int
 	, needsPubKey :: Bool
 	, rsyncOnly :: Bool
 	}
@@ -188,7 +189,6 @@ genSshKeyPair = withTempDir "git-annex-keygen" $ \dir -> do
 setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
 setupSshKeyPair sshkeypair sshdata = do
 	sshdir <- sshDir
-	let configfile = sshdir </> "config"
 	createDirectoryIfMissing True sshdir
 
 	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
@@ -200,25 +200,39 @@ setupSshKeyPair sshkeypair sshdata = do
 	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
 		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
 
+	setSshConfig sshdata
+		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) ]
+  where
+	sshprivkeyfile = "key." ++ mangleSshHostName sshdata
+	sshpubkeyfile = sshprivkeyfile ++ ".pub"
+
+{- Setups up a ssh config with a mangled hostname.
+ - Returns a modified SshData containing the mangled hostname. -}
+setSshConfig :: SshData -> [(String, String)] -> IO SshData
+setSshConfig sshdata config = do
+	sshdir <- sshDir
+	createDirectoryIfMissing True sshdir
+	let configfile = sshdir </> "config"
 	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
-		appendFile configfile $ unlines
+		appendFile configfile $ unlines $
 			[ ""
 			, "# Added automatically by git-annex"
 			, "Host " ++ mangledhost
-			, "\tHostname " ++ T.unpack (sshHostName sshdata)
-			, "\tIdentityFile ~/.ssh/" ++ sshprivkeyfile
-			]
-
+			] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
+				(settings ++ config)
 	return $ sshdata { sshHostName = T.pack mangledhost }
   where
-	sshprivkeyfile = "key." ++ mangledhost
-	sshpubkeyfile = sshprivkeyfile ++ ".pub"
-	mangledhost = mangleSshHostName
-		(T.unpack $ sshHostName sshdata)
-		(T.unpack <$> sshUserName sshdata)
+	mangledhost = mangleSshHostName sshdata
+	settings =
+		[ ("Hostname", T.unpack $ sshHostName sshdata)
+		, ("Port", show $ sshPort sshdata)
+		]
 
-mangleSshHostName :: String -> Maybe String -> String
-mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user)
+mangleSshHostName :: SshData -> String
+mangleSshHostName sshdata = "git-annex-" ++ host ++ (maybe "-" ('-':) user)
+  where
+	host = T.unpack $ sshHostName sshdata
+	user = T.unpack <$> sshUserName sshdata
 
 unMangleSshHostName :: String -> String
 unMangleSshHostName h

Assistant/WebApp/Configurators/Ssh.hs

@@ -27,9 +27,10 @@ sshConfigurator :: Widget -> Handler RepHtml
 sshConfigurator = page "Add a remote server" (Just Config)
 
 data SshInput = SshInput
-	{ hostname :: Maybe Text
-	, username :: Maybe Text
-	, directory :: Maybe Text
+	{ inputHostname :: Maybe Text
+	, inputUsername :: Maybe Text
+	, inputDirectory :: Maybe Text
+	, inputPort :: Int
 	}
 	deriving (Show)
 
@@ -37,21 +38,23 @@ data SshInput = SshInput
  - the result of such a form into a SshData. -}
 mkSshData :: SshInput -> SshData
 mkSshData s = SshData 
-	{ sshHostName = fromMaybe "" $ hostname s
-	, sshUserName = username s
-	, sshDirectory = fromMaybe "" $ directory s
+	{ sshHostName = fromMaybe "" $ inputHostname s
+	, sshUserName = inputUsername s
+	, sshDirectory = fromMaybe "" $ inputDirectory s
 	, sshRepoName = genSshRepoName
-		(T.unpack $ fromJust $ hostname s)
-		(maybe "" T.unpack $ directory s)
+		(T.unpack $ fromJust $ inputHostname s)
+		(maybe "" T.unpack $ inputDirectory s)
+	, sshPort = inputPort s
 	, needsPubKey = False
 	, rsyncOnly = False
 	}
 
 sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
 sshInputAForm hostnamefield def = SshInput
-	<$> aopt check_hostname "Host name" (Just $ hostname def)
-	<*> aopt check_username "User name" (Just $ username def)
-	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
+	<$> aopt check_hostname "Host name" (Just $ inputHostname def)
+	<*> aopt check_username "User name" (Just $ inputUsername def)
+	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
+	<*> areq intField "Port" (Just $ inputPort def)
   where
 	check_hostname = checkM (liftIO . checkdns) hostnamefield
 	checkdns t = do
@@ -90,7 +93,7 @@ getAddSshR = sshConfigurator $ do
 	u <- liftIO $ T.pack <$> myUserName
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $ sshInputAForm textField $
-			SshInput Nothing (Just u) Nothing
+			SshInput Nothing (Just u) Nothing 22
 	case result of
 		FormSuccess sshinput -> do
 			s <- liftIO $ testServer sshinput
@@ -118,7 +121,7 @@ getEnableRsyncR u = do
 				runFormGet $ renderBootstrap $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
-					| isRsyncNet (hostname sshinput') ->
+					| isRsyncNet (inputHostname sshinput') ->
 						void $ lift $ makeRsyncNet sshinput' reponame (const noop)
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
@@ -147,9 +150,10 @@ parseSshRsyncUrl :: String -> Maybe SshInput
 parseSshRsyncUrl u
 	| not (rsyncUrlIsShell u) = Nothing
 	| otherwise = Just $ SshInput
-			{ hostname = val $ unMangleSshHostName host
-			, username = if null user then Nothing else val user
-			, directory = val dir
+			{ inputHostname = val $ unMangleSshHostName host
+			, inputUsername = if null user then Nothing else val user
+			, inputDirectory = val dir
+			, inputPort = 22
 			}
   where
 	val = Just . T.pack
@@ -170,9 +174,9 @@ parseSshRsyncUrl u
  - present, while git-annex-shell is not in PATH.
  -}
 testServer :: SshInput -> IO (Either ServerStatus SshData)
-testServer (SshInput { hostname = Nothing }) = return $
+testServer (SshInput { inputHostname = Nothing }) = return $
 	Left $ UnusableServer "Please enter a host name."
-testServer sshinput@(SshInput { hostname = Just hn }) = do
+testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
 	if usable status
 		then ret status False
@@ -200,7 +204,10 @@ testServer sshinput@(SshInput { hostname = Just hn }) = do
 			 - Otherwise, trust the host key. -}
 			[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
 			, "-n" -- don't read from stdin
-			, genSshHost (fromJust $ hostname sshinput) (username sshinput)
+			, "-p", show (inputPort sshinput)
+			, genSshHost
+				(fromJust $ inputHostname sshinput)
+				(inputUsername sshinput)
 			, remotecommand
 			]
 		parsetranscript . fst <$> sshTranscript sshopts ""
@@ -248,6 +255,9 @@ makeSsh rsync setup sshdata
 		keypair <- liftIO genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
 		makeSsh' rsync setup sshdata' (Just keypair)
+	| sshPort sshdata /= 22 = do
+		sshdata' <- liftIO $ setSshConfig sshdata []
+		makeSsh' rsync setup sshdata' Nothing
 	| otherwise = makeSsh' rsync setup sshdata Nothing
 
 makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml
@@ -277,14 +287,14 @@ getAddRsyncNetR :: Handler RepHtml
 getAddRsyncNetR = do
 	((result, form), enctype) <- runFormGet $
 		renderBootstrap $ sshInputAForm hostnamefield $
-			SshInput Nothing Nothing Nothing
+			SshInput Nothing Nothing Nothing 22
 	let showform status = page "Add a Rsync.net repository" (Just Config) $
 		$(widgetFile "configurators/addrsync.net")
 	case result of
 		FormSuccess sshinput
-			| isRsyncNet (hostname sshinput) -> do
+			| isRsyncNet (inputHostname sshinput) -> do
 				let reponame = genSshRepoName "rsync.net" 
-					(maybe "" T.unpack $ directory sshinput)
+					(maybe "" T.unpack $ inputDirectory sshinput)
 				makeRsyncNet sshinput reponame setupGroup
 			| otherwise ->
 				showform $ UnusableServer
@@ -306,7 +316,7 @@ getAddRsyncNetR = do
 
 makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml
 makeRsyncNet sshinput reponame setup = do
-	knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput)
+	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
 	keypair <- liftIO $ genSshKeyPair
 	sshdata <- liftIO $ setupSshKeyPair keypair $
 		(mkSshData sshinput)

Assistant/WebApp/Form.hs

@@ -46,6 +46,18 @@ withNote field note = field { fieldView = newview }
 		in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
 
 
+{- Makes a help button be displayed after a field, that displays a help
+ - widget when clicked. Requires a unique ident for the help. -}
+withHelp :: Field sub master v -> GWidget sub master () -> Text -> Field sub master v
+withHelp field help ident = withNote field note
+  where
+	note = [whamlet|
+<a .btn data-toggle="collapse" data-target="##{ident}">
+  Help
+<div ##{ident} .collapse>
+  ^{help}
+|]
+
 data EnableEncryption = SharedEncryption | NoEncryption
 	deriving (Eq)
 

debian/changelog

@@ -26,6 +26,8 @@ git-annex (3.20121128) UNRELEASED; urgency=low
     when preferred content settings want it.
   * drop --auto: Fix dropping content when there are no preferred content
     settings.
+  * webapp: Allow user to specify the port when setting up a ssh or rsync
+    remote.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 28 Nov 2012 13:31:07 -0400
 

doc/bugs/can_not_add_ssh_remote_to_assistant_with___34__host:port__34___syntax.mdwn

@@ -26,3 +26,5 @@ this is not really a bug more of a wishlist feature.
 
 
 [[!tag /design/assistant]]
+
+> Ok, it has a port field now. [[done]] --[[Joey]]