allow making encrypted rsync special remotes

wow, that was easy!

3 files changed, 88 insertions, 56 deletions

diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index 64bb25b28..d68de5cd1 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -195,25 +195,37 @@ getAddDriveR = bootstrap (Just Config) $ do
 			hostname <- maybe "host" id <$> liftIO getHostname
 			hostlocation <- fromRepo Git.repoLocation
 			liftIO $ inDir dir $
-				void $ addRemote' hostname hostlocation
-			addRemote name dir
+				void $ makeGitRemote hostname hostlocation
+			addRemote $ makeGitRemote name dir
 
-{- Adds a remote, if there is not already one with the same location. -}
-addRemote :: String -> String -> Annex Remote
-addRemote name location = do
-	name' <- addRemote' name location
+{- Runs an action that returns a name of the remote, and finishes adding it. -}
+addRemote :: Annex String -> Annex Remote
+addRemote a = do
+	name <- a
 	void $ remoteListRefresh
-	maybe (error "failed to add remote") return =<< Remote.byName (Just name')
+	maybe (error "failed to add remote") return =<< Remote.byName (Just name)
 
-addRemote' :: String -> String -> Annex String
-addRemote' name location = inRepo $ \r ->
+{- Returns the name of the git remote it created. If there's already a
+ - remote at the location, returns its name. -}
+makeGitRemote :: String -> String -> Annex String
+makeGitRemote basename location = makeRemote basename location $ \name ->
+	void $ inRepo $
+		Git.Command.runBool "remote"
+			[Param "add", Param name, Param location]
+
+{- If there's not already a remote at the location, adds it using the
+ - action, which is passed the name of the remote to make.
+ -
+ - Returns the name of the remote. -}
+makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
+makeRemote basename location a = do
+	r <- fromRepo id
 	if (null $ filter samelocation $ Git.remotes r)
 		then do
-			let name' = uniqueRemoteName r name 0
-			void $ Git.Command.runBool "remote"
-				[Param "add", Param name', Param location] r
-			return name'
-		else return name
+			let name = uniqueRemoteName r basename 0
+			a name
+			return name
+		else return basename
 	where
 		samelocation x = Git.repoLocation x == location
 
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 86ee937ee..b4dbe4e94 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -15,10 +15,16 @@ import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
 import Assistant.WebApp.Configurators.Local
+import qualified Types.Remote as R
+import qualified Remote.Rsync as Rsync
+import qualified Command.InitRemote
+import Logs.UUID
+import Logs.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
 import System.Process (CreateProcess(..))
@@ -156,16 +162,6 @@ 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
@@ -239,52 +235,75 @@ getConfirmSshR sshdata = sshConfigurator $ do
 	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 = do
+getMakeSshGitR :: SshData -> Handler RepHtml
+getMakeSshGitR = makeSsh False
+
+getMakeSshRsyncR :: SshData -> Handler RepHtml
+getMakeSshRsyncR = makeSsh True
+
+makeSsh :: Bool -> SshData -> Handler RepHtml
+makeSsh rsync sshdata = do
 	(transcript, ok) <- liftIO $ sshTranscript [sshhost, remoteCommand]
 	if ok
 		then do
-			r <- runAnnex undefined $
-				addRemote (sshRepoName sshdata) sshurl
+			r <- runAnnex undefined makerepo
 			syncRemote r
 			redirect RepositoriesR
 		else showerr transcript
 	where
 		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 --bare --shared"
-				, "git annex init"
-				]
-		makeAuthorizedKeys =
-			[ "mkdir -p ~/.ssh"
-			, "touch ~/.ssh/authorized_keys"
-			, "chmod 600 ~/.ssh/authorized_keys"
-			, unwords
-				[ "echo"
-				, shellEscape authline
-				, ">>~/.ssh/authorized_keys"
-				]
+			, if rsync then Nothing else Just $ "git init --bare --shared"
+			, if rsync then Nothing else Just $ "git annex init"
+			, makeAuthorizedKeys sshdata
 			]
 		showerr msg = sshConfigurator $
 			$(widgetFile "configurators/makessherror")
+		{- This is a one-sided remote setup; the remote server
+		 - probably does not have a route to the client here. -}
+		makerepo = addRemote $
+			(if rsync then makeRsyncRemote else makeGitRemote)
+				(sshRepoName sshdata) sshurl
+		sshurl = T.unpack $ T.concat $ if rsync
+			then [u, h, ":", sshDirectory sshdata, "/"]
+			else ["ssh://", u, h, d, "/"]
+			where
+				u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName sshdata
+				h = sshHostName sshdata
+				d
+					| "/" `T.isPrefixOf` sshDirectory sshdata = d
+					| otherwise = T.concat ["/~/", sshDirectory sshdata]
+
+{- Inits a rsync special remote, and returns the name of the remote. -}
+makeRsyncRemote :: String -> String -> Annex String
+makeRsyncRemote name location = makeRemote name location $ const $ do
+	(u, c) <- Command.InitRemote.findByName name
+	c' <- R.setup Rsync.remote u $ M.union config c
+	describeUUID u name
+	configSet u c'
+	where
+		config = M.fromList
+			[ ("encryption", "shared")
+			, ("rsyncurl", location)
+			, ("type", "rsync")
+			]
+
+makeAuthorizedKeys :: SshData -> Maybe String
+makeAuthorizedKeys sshdata
+	| pubKey sshdata == Nothing = Nothing
+	| otherwise = Just $ join "&&" $
+		[ "mkdir -p ~/.ssh"
+		, "touch ~/.ssh/authorized_keys"
+		, "chmod 600 ~/.ssh/authorized_keys"
+		, unwords
+			[ "echo"
+			, shellEscape $ authorizedKeysLine sshdata
+			, ">>~/.ssh/authorized_keys"
+			]
+		]
 		
 authorizedKeysLine :: SshData -> String
 authorizedKeysLine sshdata@(SshData { pubKey = Just pubkey }) 
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index d22e689dd..5f8dfbbc4 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -8,7 +8,8 @@
 /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/add/ssh/make/git/#SshData MakeSshGitR GET
+/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/first FirstRepositoryR GET
 
 /transfers/#NotificationId TransfersR GET