add xmppgit command; roughed out xmpp push protocol and design

Assistant/XMPP/Git.hs

@@ -16,10 +16,17 @@ import Assistant.MakeRemote
 import Assistant.Sync
 import Annex.UUID
 import Config
+import Git.Types
+import Locations.UserConfig
 import qualified Types.Remote as Remote
 
 import Network.Protocol.XMPP
 import qualified Data.Text as T
+import System.Posix.Env
+import System.Posix.Types
+
+configKey :: Remote -> ConfigKey
+configKey r = remoteConfig (Remote.repo r) "xmppaddress"
 
 finishXMPPPairing :: JID -> UUID -> Assistant ()
 finishXMPPPairing jid u = void $ alertWhile alert $
@@ -40,10 +47,72 @@ makeXMPPGitRemote buddyname jid u = do
 	liftAnnex $ do
 		let r = Remote.repo remote
 		storeUUID (remoteConfig r "uuid") u
-		setConfig (remoteConfig r "xmppaddress") xmppaddress
+		setConfig (configKey remote) xmppaddress
 	syncNewRemote remote
 	return True
   where
 	xmppaddress = T.unpack $ formatJID $ baseJID jid
 
+{- Pushes the named refs to the remote, over XMPP.
+ -
+ - Strategy: Set GIT_SSH to run git-annex. By setting the remote url
+ - to "xmppgit:dummy", "git-annex xmppgit" will be run locally by
+ - "git push". The dataflow them becomes:
+ - 
+ - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
+ -                                                          |
+ - git receive-pack <--> xmppReceivePack <---------------> xmpp
+ - 
+ - The pipe between git-annex xmppgit and us is set up and communicated
+ - using two file descriptors, GIT_ANNEX_XMPPGIT_IN and
+ - GIT_ANNEX_XMPPGIT_OUT. It simply connects those up to its stdin
+ - and stdout, respectively, which are in turn connected to "git-push".
+ - There is also a GIT_ANNEX_XMPPGIT_CONTROL descriptor, to which an
+ - exit status is sent for xmppgit to propigate.
+ -
+ - We listen at the other end of the pipe and relay to and from XMPP.
+ -}
+xmppPush :: Remote -> [Ref] -> Assistant Bool
+xmppPush remote refs = do
+	program <- liftIO readProgramFile
 	
+	-- GIT_SSH=program git -c remote.xmppremote.url=xmppgit:dummy push xmppremote refs
+	error "TODO"
+
+relayIn :: String
+relayIn = "GIT_ANNEX_XMPPGIT_IN"
+
+relayOut :: String
+relayOut = "GIT_ANNEX_XMPPGIT_OUT"
+
+relayControl :: String
+relayControl = "GIT_ANNEX_XMPPGIT_CONTROL"
+
+relayFd :: String -> IO Fd
+relayFd var = do
+	v <- getEnv var
+	case readish =<< v of
+		Nothing -> error $ var ++ " not set"
+		Just n -> return $ Fd n
+
+{- Called by git-annex xmppgit. -}
+xmppGitRelay :: IO ()
+xmppGitRelay = do
+	inf <- relayFd relayIn
+	outf <-relayFd relayOut
+
+	void $ dupTo stdInput outf
+	void $ dupTo inf stdOutput
+
+	controlh <- fdToHandle =<< relayFd relayControl
+	s <- hGetLine controlh
+	exitWith $ case readish s of
+		Just n
+			| n == 0 -> ExitSuccess
+			| otherwise -> ExitFailure n
+		Nothing -> ExitFailure 1
+
+{- Relays git receive-pack to and from XMPP. The command needs no
+ - parameters except the directory to run in. -}
+xmppReceivePack :: Assistant Bool
+xmppReceivePack = error "TODO"

Command/XMPPGit.hs

@@ -0,0 +1,24 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.XMPPGit where
+
+import Common.Annex
+import Command
+import Assistant.XMPP.Git
+
+def :: [Command]
+def = [noCommit $ noRepo xmppGitRelay $ dontCheck repoExists $
+	command "xmppgit" paramNothing seek "git to XMPP relay (internal use)"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start _ = do
+	liftIO xmppGitRelay
+	stop

GitAnnex.hs

@@ -64,14 +64,17 @@ import qualified Command.Import
 import qualified Command.Map
 import qualified Command.Upgrade
 import qualified Command.Version
+import qualified Command.Help
 #ifdef WITH_ASSISTANT
 import qualified Command.Watch
 import qualified Command.Assistant
 #ifdef WITH_WEBAPP
 import qualified Command.WebApp
 #endif
+#ifdef WITH_XMPP
+import qualified Command.XMPPGit
+#endif
 #endif
-import qualified Command.Help
 
 cmds :: [Command]
 cmds = concat
@@ -117,14 +120,18 @@ cmds = concat
 	, Command.Map.def
 	, Command.Upgrade.def
 	, Command.Version.def
+	, Command.Help.def
 #ifdef WITH_ASSISTANT
 	, Command.Watch.def
 	, Command.Assistant.def
+	, Command.XMPPGit.def
 #ifdef WITH_WEBAPP
 	, Command.WebApp.def
 #endif
+#ifdef WITH_XMPP
+	, Command.XMPPGit.def
+#endif
 #endif
-	, Command.Help.def
 	]
 
 options :: [Option]

doc/design/assistant/xmpp.mdwn

@@ -54,6 +54,30 @@ For pairing, a chat message is sent, containing:
 
 	<git-annex xmlns='git-annex' pairing="PairReq|PairAck|PairDone uuid" />
 
+### git push over XMPP
+
+To request that a peer push to us, a chat message can be sent:
+
+	<git-annex xmlns='git-annex' startpush="" />
+
+When a peer is ready to send a git push, it sends:
+
+	<git-annex xmlns='git-annex' startingpush="" />
+
+The receiver runs `git receive-pack`, and sends back its output in
+one or more chat messages:
+
+	<git-annex xmlns='git-annex' rp="007b27ca394d26a05d9b6beefa1b07da456caa2157d7 refs/heads/git-annex report-status delete-refs side-band-64k quiet ofs-delta" />
+
+The sender replies with the data from `git push`:
+
+	<git-annex xmlns='git-annex' sp="data" />
+
+When `git receive-pack` edits, the receiver indicates its exit
+status:
+
+	<git-annex xmlns='git-annex' rpdone="0" />
+
 ### security
 
 Data git-annex sends over XMPP will be visible to the XMPP

doc/git-annex.mdwn

@@ -486,6 +486,10 @@ subdirectories).
   With --force, even files whose content is not currently available will
   be rekeyed. Use with caution.
 
+* xmppgit
+
+  This command is used internally to perform git pulls over XMPP.
+
 # OPTIONS
 
 * --force