adding ssh remote working

Rsync remote still needs work

4 files changed, 98 insertions, 28 deletions

diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 0dd3a30ec..0ff958920 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -14,6 +14,7 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
+import Assistant.WebApp.Configurators.Local
 
 import Yesod
 import Data.Text (Text)
@@ -22,6 +23,12 @@ import Network.BSD
 import System.Posix.User
 import System.Process (CreateProcess(..))
 
+sshConfigurator :: Widget -> Handler RepHtml
+sshConfigurator a = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add a remote server"
+	a
+
 data SshServer = SshServer
 	{ hostname :: Maybe Text
 	, username :: Maybe Text
@@ -66,9 +73,7 @@ usable UsableRsyncServer = True
 usable UsableSshServer = True
 
 getAddSshR :: Handler RepHtml
-getAddSshR = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Add a remote server"
+getAddSshR = sshConfigurator $ do
 	u <- liftIO $ T.pack . userName
 		<$> (getUserEntryForID =<< getEffectiveUserID)
 	((result, form), enctype) <- lift $
@@ -82,6 +87,8 @@ getAddSshR = bootstrap (Just Config) $ do
 						{ sshHostName = fromJust $ hostname sshserver'
 						, sshUserName = username sshserver'
 						, sshDirectory = fromMaybe "" $ directory sshserver'
+						-- use unmangled server for repo name
+						, sshRepoName = genSshRepoName sshserver
 						, pubKey = pubkey
 						, rsyncOnly = (status == UsableRsyncServer)
 						}
@@ -124,18 +131,16 @@ testServer sshserver = do
 				, checkcommand "git-annex-shell"
 				, checkcommand "rsync"
 				]
-			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
+				, genSshHost (fromJust $ hostname s) (username s)
 				, remotecommand
 				]
-			parsetranscript <$> sshTranscript sshopts
+			parsetranscript . fst <$> sshTranscript sshopts
 		parsetranscript s
 			| reported "git-annex-shell" = UsableSshServer
 			| reported "rsync" = UsableRsyncServer
@@ -151,8 +156,27 @@ testServer sshserver = do
 		report r = "echo " ++ token r
 		sshopt k v = concat ["-o", k, "=", v]
 
+{- ssh://user@host/path -}
+genSshUrl :: SshData -> Text
+genSshUrl s = T.concat ["ssh://", u, h, d, "/"]
+	where
+		u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName s
+		h = sshHostName s
+		d
+			| "/" `T.isPrefixOf` sshDirectory s = d
+			| otherwise = T.concat ["/~/", sshDirectory s]
+
+{- user@host or host -}
+genSshHost :: Text -> Maybe Text -> String
+genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+
+{- host_dir -}
+genSshRepoName :: SshServer -> String
+genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++
+	(maybe "" (\d -> '_' : T.unpack d) (directory s))
+
 {- The output of ssh, including both stdout and stderr. -}
-sshTranscript :: [String] -> IO String
+sshTranscript :: [String] -> IO (String, Bool)
 sshTranscript opts = do
 	(readf, writef) <- createPipe
 	readh <- fdToHandle readf
@@ -166,8 +190,8 @@ sshTranscript opts = do
 	hClose writeh
 	transcript <- hGetContentsStrict readh
 	hClose readh
-	void $ waitForProcess pid
-	return transcript
+	ok <- checkSuccessProcess pid
+	return (transcript, ok)
 
 {- 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
@@ -209,29 +233,66 @@ knownHost sshdir (SshServer { hostname = Just h }) =
 		, return False
 		)
 
-genSshUrl :: SshData -> Text
-genSshUrl s = T.concat ["ssh://", u, h, d, "/"]
-	where
-		u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName s
-		h = sshHostName s
-		d
-			| "/" `T.isPrefixOf` sshDirectory s = d
-			| otherwise = T.concat ["/~/", sshDirectory s]
-
 getConfirmSshR :: SshData -> Handler RepHtml
-getConfirmSshR sshdata = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Add a remote server"
+getConfirmSshR sshdata = sshConfigurator $ do
 	let authtoken = webAppFormAuthToken
 	let haspubkey = isJust $ pubKey sshdata
 	$(widgetFile "configurators/confirmssh")
 
+{- Creates the repository on the remote. Does any necessary ssh key setup.
+ - 
+ - This is a one-sided remote setup; the remote server probably does not
+ - have a route to the client here.
+ -}
 getMakeSshR :: SshData -> Handler RepHtml
-getMakeSshR sshdata = error "TODO"
+getMakeSshR sshdata = do
+	(transcript, ok) <- liftIO $ sshTranscript [sshhost, remoteCommand]
+	if ok
+		then do
+			r <- runAnnex undefined $
+				addRemote (sshRepoName sshdata) sshurl
+			syncRemote r
+			redirect RepositoriesR
+		else showerr transcript
 	where
-		makeAuthorizedKeys pubkey = Just $ join ";"
+		sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
+		authline = authorizedKeysLine sshdata
+		remotedir = T.unpack $ sshDirectory sshdata
+		sshurl = T.unpack $ genSshUrl sshdata
+		remoteCommand = join "&&" $ catMaybes
+			[ Just $ "mkdir -p " ++ shellEscape remotedir
+			, Just $ "cd " ++ shellEscape remotedir
+			, Just $ join "&&" makerepo
+			, if null authline
+				then Nothing
+				else Just $ join "&&" makeAuthorizedKeys
+			]
+		makerepo
+			| rsyncOnly sshdata = []
+			| otherwise =
+				[ "git init"
+				, "git annex init"
+				]
+		makeAuthorizedKeys =
 			[ "mkdir -p ~/.ssh"
 			, "touch ~/.ssh/authorized_keys"
 			, "chmod 600 ~/.ssh/authorized_keys"
-			, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
+			, unwords
+				[ "echo"
+				, shellEscape authline
+				, ">>~/.ssh/authorized_keys"
+				]
 			]
+		showerr msg = sshConfigurator $
+			$(widgetFile "configurators/makessherror")
+		
+authorizedKeysLine :: SshData -> String
+authorizedKeysLine sshdata@(SshData { pubKey = Just pubkey }) 
+	{- TODO: Locking down rsync is difficult, requiring a rather
+	 - long perl script. -}
+	| rsyncOnly sshdata = pubkey
+	| otherwise = limitcommand "git-annex-shell -c" ++ pubkey
+	where
+		limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
+authorizedKeysLine _ = ""
+
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index 26b73af9d..990e6bc48 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -74,6 +74,7 @@ data SshData = SshData
 	{ sshHostName :: Text
 	, sshUserName :: Maybe Text
 	, sshDirectory :: Text
+	, sshRepoName :: String
 	, pubKey :: Maybe PubKey
 	, rsyncOnly :: Bool
 	}
diff --git a/templates/configurators/confirmssh.hamlet b/templates/configurators/confirmssh.hamlet
index 75e27f708..60bba8485 100644
--- a/templates/configurators/confirmssh.hamlet
+++ b/templates/configurators/confirmssh.hamlet
@@ -5,8 +5,6 @@
     <div .span8>
       <p>
         The server at #{sshHostName sshdata} has been verified to be usable.
-        <br>
-        Everything checks out!
       <p>
         <a .btn .btn-primary href="@{MakeSshR sshdata}" onclick="$('#setupmodal').modal('show');">
           Clone this repository to the remote server
@@ -20,7 +18,7 @@
 <div .modal .fade #setupmodal>
   <div .modal-header>
     <h3>
-      Testing server ...
+      Making repository ...
   <div .modal-body>
     <p>
       Setting up repository on the remote server. This could take a minute.
diff --git a/templates/configurators/makessherror.hamlet b/templates/configurators/makessherror.hamlet
new file mode 100644
index 000000000..6422431cc
--- /dev/null
+++ b/templates/configurators/makessherror.hamlet
@@ -0,0 +1,10 @@
+<div .span9 .hero-unit>
+  <h2>
+    <i .icon-warning-sign></i> Failed to make repository
+  <p>
+    Something went wrong setting up the repository on the remote server.
+  <p>
+    Transcript: #{msg}
+  <p>
+    <a .btn .btn-primary href="@{MakeSshR sshdata}">
+     Retry