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