UI for adding a ssh or rsync remote

Assistant/WebApp/Configurators.hs

@@ -14,7 +14,6 @@ import Assistant.WebApp
 import Assistant.WebApp.SideBar
 import Assistant.DaemonStatus
 import Assistant.WebApp.Configurators.Local
-import Assistant.WebApp.Configurators.Ssh
 import Utility.Yesod
 import qualified Remote
 import qualified Types.Remote as Remote

Assistant/WebApp/Configurators/Local.hs

@@ -12,13 +12,9 @@ module Assistant.WebApp.Configurators.Local where
 import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.SideBar
-import Assistant.DaemonStatus
 import Assistant.Threads.MountWatcher (handleMount)
 import Utility.Yesod
-import qualified Remote
-import qualified Types.Remote as Remote
 import Remote.List
-import Annex.UUID (getUUID)
 import Init
 import qualified Git
 import qualified Git.Construct
@@ -102,7 +98,9 @@ defaultRepositoryPath firstrun = do
 		then do
 			desktop <- userDesktopDir
 			ifM (doesDirectoryExist desktop)
-				(relHome (desktop </> "annex"), return "~/annex")
+				( relHome $ desktop </> gitAnnexAssistantDefaultDir
+				, return $ "~" </> gitAnnexAssistantDefaultDir
+				)
 		else return cwd
 
 localRepositoryForm :: Form RepositoryPath
@@ -178,7 +176,7 @@ getAddDriveR = bootstrap (Just Config) $ do
 			webapp <- getYesod
 			liftIO $ syncrepo dir webapp
 			where
-				dir = mountpoint </> "annex"
+				dir = mountpoint </> gitAnnexAssistantDefaultDir
 				remotename = takeFileName mountpoint
 		{- The repo may already exist, when adding removable media
 		 - that has already been used elsewhere. -}

Assistant/WebApp/Configurators/Ssh.hs

@@ -12,33 +12,97 @@ module Assistant.WebApp.Configurators.Ssh where
 import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.SideBar
-import Assistant.DaemonStatus
-import Assistant.Threads.MountWatcher (handleMount)
 import Utility.Yesod
-import qualified Remote
-import qualified Types.Remote as Remote
-import Remote.List
-import Annex.UUID (getUUID)
-import Init
-import qualified Git
-import qualified Git.Construct
-import qualified Git.Config
-import qualified Git.Command
-import qualified Annex
-import Locations.UserConfig
-import Utility.FreeDesktop
-import Utility.Mounts
-import Utility.DiskFree
-import Utility.DataUnits
-import Utility.Network
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Char
-import System.Posix.Directory
-import qualified Control.Exception as E
+import Network.BSD
+import System.Posix.User
 
-getAddRemoteServerR :: Handler RepHtml
-getAddRemoteServerR = bootstrap (Just Config) $ do
-	error "TODO"
+data SshServer = SshServer
+	{ hostname :: Maybe Text
+	, username :: Maybe Text
+	, directory :: Maybe Text
+	}
+	deriving Show
+
+sshServerAForm :: Text -> AForm WebApp WebApp SshServer
+sshServerAForm localusername = SshServer
+	<$> aopt check_hostname "Host name" Nothing
+	<*> aopt check_username "User name" (Just $ Just localusername)
+	<*> aopt textField "Directory" (Just $ Just $ T.pack gitAnnexAssistantDefaultDir)
+	where
+		check_hostname = checkM (liftIO . checkdns) textField
+		checkdns t = do
+			let h = T.unpack t
+			r <- catchMaybeIO $ getHostByName h
+			return $ case r of
+				-- canonicalize input hostname if it had no dot
+				Just hostentry
+					| '.' `elem` h -> Right t
+					| otherwise -> Right $ T.pack $ hostName hostentry
+				Nothing -> Left bad_hostname
+
+		check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
+			bad_username textField
+		
+		bad_hostname = "cannot resolve host name" :: Text
+		bad_username = "bad user name" :: Text
+
+data ServerStatus
+	= UntestedServer
+	| UnusableServer Text -- reason why it's not usable
+	| 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
+
+getAddSshR :: Handler RepHtml
+getAddSshR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add a remote server"
+	u <- liftIO $ T.pack . userName
+		<$> (getUserEntryForID =<< getEffectiveUserID)
+	((result, form), enctype) <- lift $
+		runFormGet $ renderBootstrap $ sshServerAForm u
+	case result of
+		FormSuccess sshserver -> do
+			showform form enctype =<< liftIO (testServer sshserver)
+		_ -> showform form enctype UntestedServer
+	where
+		showform form enctype status = 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

Assistant/WebApp/routes

@@ -6,7 +6,7 @@
 /config ConfigR GET
 /config/repository RepositoriesR GET
 /config/repository/add/drive AddDriveR GET
-/config/repository/add/remoteserver AddRemoteServerR GET
+/config/repository/add/ssh AddSshR GET
 /config/repository/first FirstRepositoryR GET
 
 /transfers/#NotificationId TransfersR GET

Locations.hs

@@ -30,6 +30,7 @@ module Locations (
 	gitAnnexHtmlShim,
 	gitAnnexSshDir,
 	gitAnnexRemotesDir,
+	gitAnnexAssistantDefaultDir,
 	isLinkToAnnex,
 	annexHashes,
 	hashDirMixed,
@@ -179,6 +180,11 @@ gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
 gitAnnexRemotesDir :: Git.Repo -> FilePath
 gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"
 
+{- This is the base directory name used by the assistant when making
+ - repositories, by default. -}
+gitAnnexAssistantDefaultDir :: FilePath
+gitAnnexAssistantDefaultDir = "annex"
+
 {- Checks a symlink target to see if it appears to point to annexed content. -}
 isLinkToAnnex :: FilePath -> Bool
 isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s

templates/configurators/addssh.hamlet

@@ -0,0 +1,38 @@
+<div .span9 .hero-unit>
+  <h2>
+    Adding a remote server using ssh or rsync
+  <p>
+    Clone this repository to a ssh or rsync 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 #
+    could use a <a href="http://linode.com/">Linode</a> or another VPS, or #
+    an account on a friend's server.
+  <p>
+    $case status
+      $of UnusableServer msg
+        <div .alert .alert-error>
+          <i .icon-warning-sign></i> #{msg}
+      $of _
+        <i .icon-warning-sign></i> Do keep in mind that all your data #
+        will be synced to the server, so make sure it has enough available #
+        disk space, bandwidth, and that you trust it with your data.
+  <p>
+    <form .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{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>
+        Making a ssh connection to the server to check it. #
+        You may be prompted for your password to log into the server.

templates/configurators/repositories.hamlet

@@ -15,7 +15,7 @@
     <div .span4>
       <h3>
         <a href="@{AddDriveR}">
-          <i .icon-plus></i> Removable drive
+          <i .icon-plus-sign></i> Removable drive
       <p>
         Clone this repository to a USB drive, memory stick, or other #
         removable media.
@@ -25,7 +25,7 @@
         between computers. 
     <div .span4>
       <h3>
-        <i .icon-plus></i> Local computer
+        <i .icon-plus-sign></i> Local computer
       <p>
         Pair with a local computer to automatically keep files in sync #
         between computers on your local network.
@@ -33,7 +33,7 @@
         For easy sharing with family and friends, or between your devices.
     <div .span4>
       <h3>
-        <i .icon-plus></i> Phone
+        <i .icon-plus-sign></i> Phone
       <p>
         Save photos and recordings from your phone.
       <p>
@@ -41,7 +41,7 @@
   <div .row-fluid>
     <div .span4>
       <h3>
-        <i .icon-plus></i> The cloud
+        <i .icon-plus-sign></i> The cloud
       <p>
         Store your data on a third-party cloud platform, #
         including Amazon S3, Box.com, and Rsync.net.
@@ -50,10 +50,10 @@
         With strong encryption to protect your privacy.
     <div .span4>
       <h3>
-        <a href="@{AddRemoteServerR}">
-          <i .icon-plus></i> Remote server
+        <a href="@{AddSshR}">
+          <i .icon-plus-sign></i> Remote server
       <p>
         Set up a repository on a remote server using #
         <tt>ssh</tt> or <tt>rsync</tt>.
       <p>
-        To use your own personal cloud.
+        To build your own personal cloud.