add ssh confirmation page

also broke out webapp types into a separate module

14 files changed, 191 insertions, 97 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 6733e5a40..7da3c82e5 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -12,6 +12,7 @@ module Assistant.Threads.WebApp where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.DashBoard
 import Assistant.WebApp.SideBar
 import Assistant.WebApp.Notifications
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 721257294..d2c41a3c3 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -1,4 +1,4 @@
-{- git-annex assistant webapp data types
+{- git-annex assistant webapp core
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -6,45 +6,21 @@
  -}
 
 {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Assistant.WebApp where
 
+import Assistant.WebApp.Types
 import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Alert
 import Utility.NotificationBroadcaster
-import Utility.WebApp
 import Utility.Yesod
-import Logs.Transfer
 
 import Yesod
-import Yesod.Static
 import Text.Hamlet
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
 import Control.Concurrent.STM
 
-staticFiles "static"
-
-mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
-
-data WebApp = WebApp
-	{ threadState :: Maybe ThreadState
-	, daemonStatus :: DaemonStatusHandle
-	, scanRemotes :: ScanRemoteMap
-	, transferQueue :: TransferQueue
-	, transferSlots :: TransferSlots
-	, secretToken :: Text
-	, relDir :: Maybe FilePath
-	, getStatic :: Static
-	, webAppState :: TMVar WebAppState
-	, postFirstRun :: Maybe (IO String)
-	}
-
 data NavBarItem = DashBoard | Config | About
 	deriving (Eq)
 
@@ -87,29 +63,6 @@ bootstrap navbaritem content = do
 	where
 		navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 
-instance Yesod WebApp where
-	{- Require an auth token be set when accessing any (non-static route) -}
-	isAuthorized _ _ = checkAuthToken secretToken
-
-	{- Add the auth token to every url generated, except static subsite
-         - urls (which can show up in Permission Denied pages). -}
-	joinPath = insertAuthToken secretToken excludeStatic
-		where
-			excludeStatic [] = True
-			excludeStatic (p:_) = p /= "static"
-
-	makeSessionBackend = webAppSessionBackend
-	jsLoader _ = BottomOfHeadBlocking
-
-instance RenderMessage WebApp FormMessage where
-	renderMessage _ _ = defaultFormMessage
-
-type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
-
-data WebAppState = WebAppState
-	{ showIntro :: Bool
-	}
-
 newWebAppState :: IO (TMVar WebAppState)
 newWebAppState = liftIO $ atomically $
 	newTMVar $ WebAppState { showIntro = True }
@@ -149,18 +102,6 @@ getNotifier selector = do
 	webapp <- getYesod
 	liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
 
-instance PathPiece NotificationId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance PathPiece AlertId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance PathPiece Transfer where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
 {- Adds the auth parameter as a hidden field on a form. Must be put into
  - every form. -}
 webAppFormAuthToken :: Widget
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index 4d4d5c916..ec0a53ea8 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.DaemonStatus
 import Assistant.WebApp.Configurators.Local
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index beb41e1f1..42628fedf 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Local where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.Threads.MountWatcher (handleMount)
 import Utility.Yesod
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 9d728ce7e..0dd3a30ec 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Ssh where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
 
@@ -26,9 +27,7 @@ data SshServer = SshServer
 	, username :: Maybe Text
 	, directory :: Maybe Text
 	}
-	deriving Show
-
-type PubKey = String
+	deriving (Show)
 
 sshServerAForm :: Text -> AForm WebApp WebApp SshServer
 sshServerAForm localusername = SshServer
@@ -58,6 +57,7 @@ data ServerStatus
 	| UnusableServer Text -- reason why it's not usable
 	| UsableRsyncServer
 	| UsableSshServer
+	deriving (Eq)
 
 usable :: ServerStatus -> Bool
 usable UntestedServer = False
@@ -77,7 +77,14 @@ getAddSshR = bootstrap (Just Config) $ do
 		FormSuccess sshserver -> do
 			(status, sshserver', pubkey) <- liftIO $ testServer sshserver
 			if usable status
-				then error $ "TODO " ++ show sshserver'
+				then lift $ redirect $ ConfirmSshR $
+					SshData 
+						{ sshHostName = fromJust $ hostname sshserver'
+						, sshUserName = username sshserver'
+						, sshDirectory = fromMaybe "" $ directory sshserver'
+						, pubKey = pubkey
+						, rsyncOnly = (status == UsableRsyncServer)
+						}
 				else showform form enctype status
 		_ -> showform form enctype UntestedServer
 	where
@@ -85,15 +92,6 @@ getAddSshR = bootstrap (Just Config) $ do
 			let authtoken = webAppFormAuthToken
 			$(widgetFile "configurators/addssh")
 
-		buttonText :: ServerStatus -> Text
-		buttonText UsableRsyncServer = "Make rsync repository"
-		buttonText UsableSshServer = "Clone repository to ssh server"
-		buttonText _ = "Check this server"
-
-		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
@@ -153,6 +151,7 @@ testServer sshserver = do
 		report r = "echo " ++ token r
 		sshopt k v = concat ["-o", k, "=", v]
 
+{- The output of ssh, including both stdout and stderr. -}
 sshTranscript :: [String] -> IO String
 sshTranscript opts = do
 	(readf, writef) <- createPipe
@@ -210,9 +209,29 @@ knownHost sshdir (SshServer { hostname = Just h }) =
 		, return False
 		)
 
-makeAuthorizedKeys pubkey = Just $ join ";"
-	[ "mkdir -p ~/.ssh"
-	, "touch ~/.ssh/authorized_keys"
-	, "chmod 600 ~/.ssh/authorized_keys"
-	, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
-	]
+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"
+	let authtoken = webAppFormAuthToken
+	let haspubkey = isJust $ pubKey sshdata
+	$(widgetFile "configurators/confirmssh")
+
+getMakeSshR :: SshData -> Handler RepHtml
+getMakeSshR sshdata = error "TODO"
+	where
+		makeAuthorizedKeys pubkey = Just $ join ";"
+			[ "mkdir -p ~/.ssh"
+			, "touch ~/.ssh/authorized_keys"
+			, "chmod 600 ~/.ssh/authorized_keys"
+			, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
+			]
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 1b052d84f..992e6ba26 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.DashBoard where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.WebApp.Notifications
 import Assistant.WebApp.Configurators
diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs
index b0a9e4d98..3fc0f2374 100644
--- a/Assistant/WebApp/Documentation.hs
+++ b/Assistant/WebApp/Documentation.hs
@@ -10,6 +10,7 @@
 module Assistant.WebApp.Documentation where
 
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
 
diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs
index 3aa56424a..0ef890f68 100644
--- a/Assistant/WebApp/Notifications.hs
+++ b/Assistant/WebApp/Notifications.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Notifications where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Utility.Yesod
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index d44c75d43..20fd09c2e 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.SideBar where
 
 import Assistant.Common
 import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.WebApp.Notifications
 import Assistant.DaemonStatus
 import Assistant.Alert
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
new file mode 100644
index 000000000..988f909d7
--- /dev/null
+++ b/Assistant/WebApp/Types.hs
@@ -0,0 +1,95 @@
+{- git-annex assistant webapp types
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Assistant.WebApp.Types where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Assistant.Alert
+import Utility.NotificationBroadcaster
+import Utility.WebApp
+import Logs.Transfer
+
+import Yesod
+import Yesod.Static
+import Data.Text (Text, pack, unpack)
+import Control.Concurrent.STM
+
+staticFiles "static"
+
+mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
+
+data WebApp = WebApp
+	{ threadState :: Maybe ThreadState
+	, daemonStatus :: DaemonStatusHandle
+	, scanRemotes :: ScanRemoteMap
+	, transferQueue :: TransferQueue
+	, transferSlots :: TransferSlots
+	, secretToken :: Text
+	, relDir :: Maybe FilePath
+	, getStatic :: Static
+	, webAppState :: TMVar WebAppState
+	, postFirstRun :: Maybe (IO String)
+	}
+
+instance Yesod WebApp where
+	{- Require an auth token be set when accessing any (non-static route) -}
+	isAuthorized _ _ = checkAuthToken secretToken
+
+	{- Add the auth token to every url generated, except static subsite
+         - urls (which can show up in Permission Denied pages). -}
+	joinPath = insertAuthToken secretToken excludeStatic
+		where
+			excludeStatic [] = True
+			excludeStatic (p:_) = p /= "static"
+
+	makeSessionBackend = webAppSessionBackend
+	jsLoader _ = BottomOfHeadBlocking
+
+instance RenderMessage WebApp FormMessage where
+	renderMessage _ _ = defaultFormMessage
+
+type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
+
+data WebAppState = WebAppState
+	{ showIntro :: Bool
+	}
+
+type PubKey = String
+
+data SshData = SshData
+	{ sshHostName :: Text
+	, sshUserName :: Maybe Text
+	, sshDirectory :: Text
+	, pubKey :: Maybe PubKey
+	, rsyncOnly :: Bool
+	}
+	deriving (Read, Show, Eq)
+
+instance PathPiece SshData where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+
+instance PathPiece NotificationId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece AlertId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece Transfer where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index eaa5ac7d1..d22e689dd 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -7,6 +7,8 @@
 /config/repository RepositoriesR GET
 /config/repository/add/drive AddDriveR GET
 /config/repository/add/ssh AddSshR GET
+/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
+/config/repository/add/ssh/make/#SshData MakeSshR GET
 /config/repository/first FirstRepositoryR GET
 
 /transfers/#NotificationId TransfersR GET
diff --git a/templates/configurators/addssh.hamlet b/templates/configurators/addssh.hamlet
index 3fa72d9b9..03a99fd96 100644
--- a/templates/configurators/addssh.hamlet
+++ b/templates/configurators/addssh.hamlet
@@ -1,13 +1,13 @@
 <div .span9 .hero-unit>
   <h2>
-    Adding a remote server using ssh or rsync
+    Adding a remote server using ssh
   <p>
-    Clone this repository to a ssh or rsync server. Your data will be #
+    Clone this repository to a ssh server. Your data will be #
     uploaded to the server. If you set up other devices to use the same #
     server, they will all be kept in sync, using the server as a central #
     hub.
   <p>
-    You can use nearly any server that has ssh or rsync. For example, you #
+    You can use nearly any server that has ssh and rsync. For example, you #
     could use a <a href="http://linode.com/">Linode</a> or another VPS, or #
     an account on a friend's server.
   <p>
@@ -25,15 +25,14 @@
         ^{form}
         ^{authtoken}
         <div .form-actions>
-          <button .btn .btn-primary type=submit :willTest status:onclick="$('#testmodal').modal('show');">
-            #{buttonText status}
-$if willTest status
-  <div .modal .fade #testmodal>
-    <div .modal-header>
-      <h3>
-        Testing server ...
-    <div .modal-body>
-      <p>
-        Checking ssh connection to the server. This could take a minute.
-      <p>
-        You may be prompted for your password to log into the server.
+          <button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">
+            Check this server
+<div .modal .fade #testmodal>
+  <div .modal-header>
+    <h3>
+      Testing server ...
+  <div .modal-body>
+    <p>
+      Checking ssh connection to the server. This could take a minute.
+    <p>
+      You may be prompted for your password to log into the server.
diff --git a/templates/configurators/confirmssh.hamlet b/templates/configurators/confirmssh.hamlet
new file mode 100644
index 000000000..75e27f708
--- /dev/null
+++ b/templates/configurators/confirmssh.hamlet
@@ -0,0 +1,31 @@
+<div .span9 .hero-unit>
+  <h2>
+    Ready to add remote server
+  <div .row-fluid>
+    <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
+    <div .span4>
+      $if haspubkey
+        <div .alert .alert-info>
+          <i .icon-info-sign></i> #
+          <p>
+            A ssh key will be installed on the server, allowing git-annex to #
+            access it securely without a password.
+<div .modal .fade #setupmodal>
+  <div .modal-header>
+    <h3>
+      Testing server ...
+  <div .modal-body>
+    <p>
+      Setting up repository on the remote server. This could take a minute.
+    $if haspubkey
+      <p>
+        You will be prompted once more for your ssh password. A ssh key
+        is being installed on the server, allowing git-annex to access it
+        securely without a password.
diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet
index 06c1b3299..ee822671f 100644
--- a/templates/configurators/repositories.hamlet
+++ b/templates/configurators/repositories.hamlet
@@ -54,6 +54,6 @@
           <i .icon-plus-sign></i> Remote server
       <p>
         Set up a repository on a remote server using #
-        <tt>ssh</tt> or <tt>rsync</tt>.
+        <tt>ssh</tt>.
       <p>
         To build your own personal cloud.