use xmpp::user@host for xmpp remotes

Inject the required git-remote-xmpp into PATH when running xmpp git push.
Rest of the time it will not be in PATH, and git won't be able to talk to
xmpp remotes.

Assistant/XMPP/Git.hs

@@ -24,6 +24,7 @@ import qualified Git.Branch
 import qualified Annex.Branch
 import Locations.UserConfig
 import qualified Types.Remote as Remote
+import Utility.FileMode
 
 import Network.Protocol.XMPP
 import qualified Data.Text as T
@@ -43,15 +44,9 @@ finishXMPPPairing jid u = void $ alertWhile alert $
 	buddy = T.unpack $ buddyName jid
 	alert = pairRequestAcknowledgedAlert buddy Nothing
 
-{- A git remote for an XMPP user? This is represented as a git remote
- - that has no location set. The user's XMPP address is stored in the
- - xmppaddress setting.
- -
- - The UUID of their remote is also stored as usual.
- -}
 makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
 makeXMPPGitRemote buddyname jid u = do
-	remote <- liftAnnex $ addRemote $ makeGitRemote buddyname "" -- no location
+	remote <- liftAnnex $ addRemote $ makeGitRemote buddyname xmppaddress
 	liftAnnex $ do
 		let r = Remote.repo remote
 		storeUUID (remoteConfig r "uuid") u
@@ -59,15 +54,15 @@ makeXMPPGitRemote buddyname jid u = do
 	syncNewRemote remote
 	return True
   where
-	xmppaddress = T.unpack $ formatJID $ baseJID jid
+	xmppaddress = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
 
 {- Pushes the named refs to the remote, over XMPP, communicating with a
  - specific client that either requested the push, or responded to our
- - StartingPush message.
+ - message.
  -
- - Strategy: Set GIT_SSH to run git-annex. By setting the remote url
+ - To handle xmpp:: urls, git push will run git-remote-xmpp, which is
- - to "xmppgit:dummy", "git-annex xmppgit" will be run locally by
+ - injected into its PATH, and in turn runs git-annex xmppgit. The
- - "git push". The dataflow them becomes:
+ - dataflow them becomes:
  - 
  - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
  -                                                          |
@@ -85,22 +80,25 @@ makeXMPPGitRemote buddyname jid u = do
 xmppPush :: ClientID -> Remote -> [Ref] -> Assistant Bool
 xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
 	sendNetMessage $ StartingPush cid
-	program <- liftIO readProgramFile
 
 	(Fd inf, writepush) <- liftIO createPipe
 	(readpush, Fd outf) <- liftIO createPipe
 	(Fd controlf, writecontrol) <- liftIO createPipe
 
+	tmp <- liftAnnex $ fromRepo gitAnnexTmpDir
+	let tmpdir = tmp </> "xmppgit"
+	installwrapper tmpdir
+
 	env <- liftIO getEnvironment
+	path <- liftIO getSearchPath
 	let myenv =
-		[ ("GIT_SSH", program)
+		[ ("PATH", join [searchPathSeparator] $ tmpdir:path)
 		, (relayIn, show inf)
 		, (relayOut, show outf)
 		, (relayControl, show controlf)
 		]
 	g <- liftAnnex gitRepo
 	let name = Remote.name remote
-	let mainparams = [Param "-c", Param $ "remote."++name++".url=xmpp:client"]
 	let params = Param "push" : Param name : map (Param . show) refs
 
 	inh <- liftIO $ fdToHandle readpush
@@ -112,7 +110,7 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
 	t2 <- forkIO <~> fromxmpp outh controlh
 
 	ok <- liftIO $ boolSystemEnv "git"
-		(mainparams ++ gitCommandLine params g)
+		(gitCommandLine params g)
 		(Just $ env ++ myenv)
 	liftIO $ mapM_ killThread [t1, t2]
 	return ok
@@ -129,6 +127,15 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
 			(ReceivePackDone _ exitcode) -> do
 				liftIO $ hPutStrLn controlh (show exitcode)
 			_ -> noop
+	installwrapper tmpdir = liftIO $ do
+		createDirectoryIfMissing True tmpdir
+		let wrapper = tmpdir </> "git-remote-xmpp"
+		program <- readProgramFile
+		writeFile wrapper $ unlines
+			[ "#!/bin/sh"
+			, "exec " ++ program ++ " xmppgit"
+			]
+		modifyFileMode wrapper $ addModes executeModes
 
 relayIn :: String
 relayIn = "GIT_ANNEX_XMPPGIT_IN"

Command/XMPPGit.hs

@@ -20,5 +20,22 @@ seek = [withWords start]
 
 start :: [String] -> CommandStart
 start _ = do
+	liftIO gitRemoteHelper
 	liftIO xmppGitRelay
 	stop
+
+{- A basic implementation of the git-remote-helpers protocol. -}
+gitRemoteHelper :: IO ()
+gitRemoteHelper = do
+	expect "capabilities"
+	respond ["connect"]
+	expect "connect git-receive-pack"
+	respond []
+  where
+	expect s = do
+		cmd <- getLine
+		unless (cmd == s) $
+			error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ cmd
+	respond l = do
+		mapM_ putStrLn l
+		putStrLn ""

Utility/FileMode.hs

@@ -48,6 +48,9 @@ writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
 readModes :: [FileMode]
 readModes = [ownerReadMode, groupReadMode, otherReadMode]
 
+executeModes :: [FileMode]
+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
 {- Removes the write bits from a file. -}
 preventWrite :: FilePath -> IO ()
 preventWrite f = modifyFileMode f $ removeModes writeModes
@@ -72,9 +75,7 @@ isSymLink = checkMode symbolicLinkMode
 
 {- Checks if a file has any executable bits set. -}
 isExecutable :: FileMode -> Bool
-isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
-	where
-		ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
 
 {- Runs an action without that pesky umask influencing it, unless the
  - passed FileMode is the standard one. -}