UI for enabling special remotes

Now other repositories can configure special remotes, and when their
configuration has propigated out, they'll appear in the webapp's list of
repositories, with a link to enable them.

Added support for enabling rsync special remotes, and directory special
remotes that are on removable drives. However, encrypted directory special
remotes are not supported yet. The removable drive configuator doesn't
support them yet anyway.

6 files changed, 206 insertions, 87 deletions

diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index ded2b0056..32df9cd0b 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -186,8 +186,19 @@ setupSshKeyPair sshkeypair sshdata = do
 	where
 		sshprivkeyfile = "key." ++ mangledhost
 		sshpubkeyfile = sshprivkeyfile ++ ".pub"
-		mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
-		user = maybe "" (\u -> '-' : T.unpack u) (sshUserName sshdata)
+		mangledhost = mangleSshHostName
+			(T.unpack $ sshHostName sshdata)
+			(T.unpack <$> sshUserName sshdata)
+
+mangleSshHostName :: String -> Maybe String -> String
+mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user)
+
+unMangleSshHostName :: String -> String
+unMangleSshHostName h
+	| "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits)
+	| otherwise = h
+	where
+		dashbits = split "-" h
 
 {- Does ssh have known_hosts data for a hostname? -}
 knownHost :: Text -> IO Bool
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index f6de32166..3f6a3f3e1 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -19,9 +19,12 @@ import Utility.Yesod
 import qualified Remote
 import qualified Types.Remote as Remote
 import Annex.UUID (getUUID)
+import Logs.Remote
+import Logs.Trust
 
 import Yesod
 import Data.Text (Text)
+import qualified Data.Map as M
 
 {- The main configuration screen. -}
 getConfigR :: Handler RepHtml
@@ -38,26 +41,45 @@ getRepositoriesR :: Handler RepHtml
 getRepositoriesR = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Repositories"
-	repolist <- lift repoList
+	repolist <- lift $ repoList False
 	$(widgetFile "configurators/repositories")
 
 {- A numbered list of known repositories, including the current one. -}
-repoList :: Handler [(String, String)]
-repoList = do
-	rs <- filter (not . Remote.readonly) . knownRemotes <$>
-		(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
-	l <- runAnnex [] $ do
-		u <- getUUID
-		Remote.prettyListUUIDs $ nub $ u : map Remote.uuid rs
-	return $ zip counter l
+repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))]
+repoList onlyconfigured
+	| onlyconfigured = list =<< configured
+	| otherwise = list =<< (++) <$> configured <*> unconfigured
 	where
+		configured = do
+			rs <- filter (not . Remote.readonly) . knownRemotes <$>
+				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
+			runAnnex [] $ do
+				u <- getUUID
+				return $ zip (u : map Remote.uuid rs) (repeat Nothing)
+		unconfigured = runAnnex [] $ do
+			m <- readRemoteLog
+			catMaybes . map (findtype m) . snd
+				<$> (trustPartition DeadTrusted $ M.keys m)
+		findtype m u = case M.lookup u m of
+			Nothing -> Nothing
+			Just c -> case M.lookup "type" c of
+				Just "rsync" -> u `enableswith` EnableRsyncR
+				Just "directory" -> u `enableswith` EnableDirectoryR
+				_ -> Nothing
+		u `enableswith` r = Just (u, Just $ r u)
+		list l = runAnnex [] $ do
+			let l' = nubBy (\x y -> fst x == fst y) l
+			zip3
+				<$> pure counter
+				<*> Remote.prettyListUUIDs (map fst l')
+				<*> pure (map snd l')
 		counter = map show ([1..] :: [Int])
 
 {- An intro message, list of repositories, and nudge to make more. -}
 introDisplay :: Text -> Widget
 introDisplay ident = do
 	webapp <- lift getYesod
-	repolist <- lift repoList
+	repolist <- lift $ repoList True
 	let n = length repolist
 	let numrepos = show n
 	let notenough = n < enough
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index dd546881b..e77986674 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -27,6 +27,7 @@ import Utility.Mounts
 import Utility.DiskFree
 import Utility.DataUnits
 import Utility.Network
+import Remote (prettyListUUIDs)
 
 import Yesod
 import Data.Text (Text)
@@ -194,6 +195,14 @@ getAddDriveR = bootstrap (Just Config) $ do
 				void $ makeGitRemote hostname hostlocation
 			addRemote $ makeGitRemote name dir
 
+getEnableDirectoryR :: UUID -> Handler RepHtml
+getEnableDirectoryR uuid = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Enable a repository"
+	description <- lift $ runAnnex "" $
+		T.pack . concat <$> prettyListUUIDs [uuid]
+	$(widgetFile "configurators/enabledirectory")
+
 {- Start syncing a newly added remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
 syncRemote remote = do
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 925ed23c5..ac705de35 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -16,10 +16,14 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
+import Utility.RsyncFile (rsyncUrlIsShell)
+import Logs.Remote
+import Remote
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Map as M
 import Network.BSD
 import System.Posix.User
 
@@ -29,32 +33,32 @@ sshConfigurator a = bootstrap (Just Config) $ do
 	setTitle "Add a remote server"
 	a
 
-data SshServer = SshServer
+data SshInput = SshInput
 	{ hostname :: Maybe Text
 	, username :: Maybe Text
 	, directory :: Maybe Text
 	}
 	deriving (Show)
 
-{- SshServer is only used for applicative form prompting, this converts
+{- SshInput is only used for applicative form prompting, this converts
  - the result of such a form into a SshData. -}
-mkSshData :: SshServer -> SshData
-mkSshData sshserver = SshData 
-	{ sshHostName = fromMaybe "" $ hostname sshserver
-	, sshUserName = username sshserver
-	, sshDirectory = fromMaybe "" $ directory sshserver
+mkSshData :: SshInput -> SshData
+mkSshData s = SshData 
+	{ sshHostName = fromMaybe "" $ hostname s
+	, sshUserName = username s
+	, sshDirectory = fromMaybe "" $ directory s
 	, sshRepoName = genSshRepoName
-		(T.unpack $ fromJust $ hostname sshserver)
-		(maybe "" T.unpack $ directory sshserver)
+		(T.unpack $ fromJust $ hostname s)
+		(maybe "" T.unpack $ directory s)
 	, needsPubKey = False
 	, rsyncOnly = False
 	}
 
-sshServerAForm :: Maybe Text -> AForm WebApp WebApp SshServer
-sshServerAForm localusername = SshServer
-	<$> aopt check_hostname "Host name" Nothing
-	<*> aopt check_username "User name" (Just localusername)
-	<*> aopt textField "Directory" (Just $ Just $ T.pack gitAnnexAssistantDefaultDir)
+sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput
+sshInputAForm 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)
 	where
 		check_hostname = checkM (liftIO . checkdns) textField
 		checkdns t = do
@@ -77,37 +81,92 @@ data ServerStatus
 	= UntestedServer
 	| UnusableServer Text -- reason why it's not usable
 	| UsableRsyncServer
-	| UsableSshServer
+	| UsableSshInput
 	deriving (Eq)
 
 usable :: ServerStatus -> Bool
 usable UntestedServer = False
 usable (UnusableServer _) = False
 usable UsableRsyncServer = True
-usable UsableSshServer = True
+usable UsableSshInput = True
 
 getAddSshR :: Handler RepHtml
 getAddSshR = sshConfigurator $ do
 	u <- liftIO $ T.pack . userName
 		<$> (getUserEntryForID =<< getEffectiveUserID)
 	((result, form), enctype) <- lift $
-		runFormGet $ renderBootstrap $ sshServerAForm (Just u)
+		runFormGet $ renderBootstrap $ sshInputAForm $
+			SshInput Nothing (Just u) Nothing
 	case result of
-		FormSuccess sshserver -> do
-			(status, needspubkey) <- liftIO $ testServer sshserver
-			if usable status
-				then lift $ redirect $ ConfirmSshR $
-					(mkSshData sshserver)
-						{ needsPubKey = needspubkey
-						, rsyncOnly = status == UsableRsyncServer
-						}
-				else showform form enctype status
+		FormSuccess sshinput -> do
+			s <- liftIO $ testServer sshinput
+			case s of
+				Left status -> showform form enctype status
+				Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
 		_ -> showform form enctype UntestedServer
 	where
 		showform form enctype status = do
 			let authtoken = webAppFormAuthToken
 			$(widgetFile "configurators/ssh/add")
 
+{- To enable an existing rsync special remote, parse the SshInput from
+ - its rsyncurl, and display a form whose only real purpose is to check
+ - if ssh public keys need to be set up. From there, we can proceed with
+ - the usual repo setup; all that code is idempotent.
+ -
+ - Note that there's no EnableSshR because ssh remotes are not special
+ - remotes, and so their configuration is not shared between repositories.
+ -}
+getEnableRsyncR :: UUID -> Handler RepHtml
+getEnableRsyncR u = do
+	m <- runAnnex M.empty readRemoteLog
+	case parseSshRsyncUrl =<< M.lookup "rsyncurl" =<< M.lookup u m of
+		Nothing -> redirect AddSshR
+		Just sshinput -> sshConfigurator $ do
+			((result, form), enctype) <- lift $
+				runFormGet $ renderBootstrap $ sshInputAForm sshinput
+			case result of
+				FormSuccess sshinput'
+					| isRsyncNet (hostname sshinput') ->
+						void $ lift $ makeRsyncNet sshinput'
+					| otherwise -> do
+						s <- liftIO $ testServer sshinput'
+						case s of
+							Left status -> showform form enctype status
+							Right sshdata -> enable sshdata
+				_ -> showform form enctype UntestedServer
+	where
+		showform form enctype status = do
+			description <- lift $ runAnnex "" $
+				T.pack . concat <$> prettyListUUIDs [u]
+			let authtoken = webAppFormAuthToken
+			$(widgetFile "configurators/ssh/enable")
+		enable sshdata = 
+			lift $ redirect $ ConfirmSshR $
+				sshdata { rsyncOnly = True }
+
+{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
+ - url; rsync:// urls or bare path names are not supported.
+ -
+ - The hostname is stored mangled in the remote log for rsync special
+ - remotes configured by this webapp. So that mangling has to reversed
+ - here to get back the original hostname.
+ -}
+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
+			}
+		where
+			val = Just . T.pack
+			(userhost, dir) = separate (== ':') u
+			(user, host) = if '@' `elem` userhost
+				then separate (== '@') userhost
+				else (userhost, "")
+
 {- Test if we can ssh into the server.
  -
  - Two probe attempts are made. First, try sshing in using the existing
@@ -118,17 +177,24 @@ getAddSshR = sshConfigurator $ do
  - Once logged into the server, probe to see if git-annex-shell is
  - available, or rsync.
  -}
-testServer :: SshServer -> IO (ServerStatus, Bool)
-testServer (SshServer { hostname = Nothing }) = return
-	(UnusableServer "Please enter a host name.", False)
-testServer sshserver@(SshServer { hostname = Just hn }) = do
+testServer :: SshInput -> IO (Either ServerStatus SshData)
+testServer (SshInput { hostname = Nothing }) = return $
+	Left $ UnusableServer "Please enter a host name."
+testServer sshinput@(SshInput { hostname = Just hn }) = do
 	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
 	if usable status
-		then return (status, False)
+		then ret status False
 		else do
 			status' <- probe []
-			return (status', True)
+			if usable status'
+				then ret status' True
+				else return $ Left status'
 	where
+		ret status needspubkey = return $ Right $
+			(mkSshData sshinput)
+				{ needsPubKey = needspubkey
+				, rsyncOnly = status == UsableRsyncServer
+				}
 		probe extraopts = do
 			let remotecommand = join ";"
 				[ report "loggedin"
@@ -142,12 +208,12 @@ testServer sshserver@(SshServer { 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 sshserver) (username sshserver)
+				, genSshHost (fromJust $ hostname sshinput) (username sshinput)
 				, remotecommand
 				]
 			parsetranscript . fst <$> sshTranscript sshopts ""
 		parsetranscript s
-			| reported "git-annex-shell" = UsableSshServer
+			| reported "git-annex-shell" = UsableSshInput
 			| reported "rsync" = UsableRsyncServer
 			| reported "loggedin" = UnusableServer
 				"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
@@ -221,50 +287,53 @@ makeSshRepo forcersync sshdata = do
 getAddRsyncNetR :: Handler RepHtml
 getAddRsyncNetR = do
 	((result, form), enctype) <- runFormGet $
-		renderBootstrap $ sshServerAForm Nothing
+		renderBootstrap $ sshInputAForm $
+			SshInput Nothing Nothing Nothing
 	let showform status = bootstrap (Just Config) $ do
 		sideBarDisplay
 		setTitle "Add a Rsync.net repository"	
 		let authtoken = webAppFormAuthToken
 		$(widgetFile "configurators/addrsync.net")
 	case result of
-		FormSuccess sshserver -> do
-			knownhost <- liftIO $ maybe (return False) knownHost (hostname sshserver)
-			keypair <- liftIO $ genSshKeyPair
-			sshdata <- liftIO $ setupSshKeyPair keypair
-				(mkSshData sshserver)
-					{ needsPubKey = True
-					, rsyncOnly = True
-					, sshRepoName = "rsync.net"
-					}
-			{- I'd prefer to separate commands with && , but
-			 - rsync.net's shell does not support that.
-			 -
-			 - The dd method of appending to the
-			 - authorized_keys file is the one recommended by
-			 - rsync.net documentation. I touch the file first
-			 - to not need to use a different method to create
-			 - it.
-			 -}
-			let remotecommand = join ";"
-				[ "mkdir -p .ssh"
-				, "touch .ssh/authorized_keys"
-				, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
-				, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
-				]
-			let sshopts = filter (not . null)
-				[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
-				, genSshHost (sshHostName sshdata) (sshUserName sshdata)
-				, remotecommand
-				]
-
-			let host = fromMaybe "" $ hostname sshserver
-			checkhost host showform $
-				sshSetup sshopts (sshPubKey keypair) $
-					makeSshRepo True sshdata
+		FormSuccess sshinput
+			| isRsyncNet (hostname sshinput) ->
+				makeRsyncNet sshinput
+			| otherwise ->
+				showform $ UnusableServer
+					"That is not a rsync.net host name."
 		_ -> showform UntestedServer
-	where
-		checkhost host showform a
-			| ".rsync.net" `T.isSuffixOf` T.toLower host = a
-			| otherwise = showform $ UnusableServer
-				"That is not a rsync.net host name."
+
+makeRsyncNet :: SshInput -> Handler RepHtml
+makeRsyncNet sshinput = do
+	knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput)
+	keypair <- liftIO $ genSshKeyPair
+	sshdata <- liftIO $ setupSshKeyPair keypair $
+		(mkSshData sshinput)
+			{ sshRepoName = "rsync.net"
+			, needsPubKey = True
+			, rsyncOnly = True
+			}
+	{- I'd prefer to separate commands with && , but
+	 - rsync.net's shell does not support that.
+	 -
+	 - The dd method of appending to the authorized_keys file is the
+	 - one recommended by rsync.net documentation. I touch the file first
+	 - to not need to use a different method to create it.
+	 -}
+	let remotecommand = join ";"
+		[ "mkdir -p .ssh"
+		, "touch .ssh/authorized_keys"
+		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
+		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
+		]
+	let sshopts = filter (not . null)
+		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+		, genSshHost (sshHostName sshdata) (sshUserName sshdata)
+		, remotecommand
+		]
+	sshSetup sshopts (sshPubKey keypair) $
+		makeSshRepo True sshdata
+
+isRsyncNet :: Maybe Text -> Bool
+isRsyncNet Nothing = False
+isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index 8cf5d40ad..c00150b65 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -91,3 +91,7 @@ instance PathPiece PairMsg where
 instance PathPiece SecretReminder where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
+
+instance PathPiece UUID where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 10f72a87f..bfc658372 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -5,17 +5,21 @@
 
 /config ConfigR GET
 /config/repository RepositoriesR GET
+/config/repository/first FirstRepositoryR 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/git/#SshData MakeSshGitR GET
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/add/rsync.net AddRsyncNetR GET
+
 /config/repository/pair/start StartPairR GET
 /config/repository/pair/inprogress/#SecretReminder InprogressPairR GET
 /config/repository/pair/finish/#PairMsg FinishPairR GET
 
-/config/repository/first FirstRepositoryR GET
+/config/repository/enable/rsync/#UUID EnableRsyncR GET
+/config/repository/enable/directory/#UUID EnableDirectoryR GET
 
 /transfers/#NotificationId TransfersR GET
 /sidebar/#NotificationId SideBarR GET