data types and xml generation/parsing for xmpp push

Assistant/Types/NetMessager.hs

@@ -13,6 +13,7 @@ import Assistant.Pairing
 import Data.Text (Text)
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
+import Data.ByteString (ByteString)
 
 {- Messages that can be sent out of band by a network messager. -}
 data NetMessage 
@@ -23,6 +24,16 @@ data NetMessage
 	-- notification about a stage in the pairing process,
 	-- involving a client identified by the Text, and a UUID.
 	| PairingNotification PairStage Text UUID
+	-- request that a git push be sent over the out of band network
+	| PushRequest
+	-- indicates that a PushRequest has been seen and a push is starting
+	| StartingPush
+	-- a chunk of output of git receive-pack
+	| ReceivePackOutput ByteString
+	-- a chuck of output of git send-pack
+	| SendPackOutput ByteString
+	-- sent when git receive-pack exits, with its exit code
+	| ReceivePackDone ExitCode
 	deriving (Show)
 
 data NetMessagerControl = NetMessagerControl

Assistant/XMPP.hs

@@ -5,25 +5,34 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Assistant.XMPP where
 
 import Assistant.Common
 import Assistant.Types.NetMessager
 import Assistant.Pairing
 
-import Network.Protocol.XMPP
+import Network.Protocol.XMPP hiding (Node)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
 import Data.XML.Types
+import qualified Codec.Binary.Base64 as B64
 
 {- Name of the git-annex tag, in our own XML namespace.
  - (Not using a namespace URL to avoid unnecessary bloat.) -}
 gitAnnexTagName :: Name
-gitAnnexTagName  = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing
+gitAnnexTagName  = "{git-annex}git-annex"
 
 {- Creates a git-annex tag containing a particular attribute and value. -}
 gitAnnexTag :: Name -> Text -> Element
-gitAnnexTag attr val = Element gitAnnexTagName [(attr, [ContentText val])] []
+gitAnnexTag attr val = gitAnnexTagContent attr val []
+
+{- Also with some content. -}
+gitAnnexTagContent :: Name -> Text -> [Node] -> Element
+gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]
 
 isGitAnnexTag :: Element -> Bool
 isGitAnnexTag t = elementName t == gitAnnexTagName
@@ -66,8 +75,11 @@ gitAnnexSignature :: Presence
 gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
 
 {- A message with a git-annex tag in it. -}
-gitAnnexMessage :: Element -> Message
+gitAnnexMessage :: Element -> JID -> JID -> Message
-gitAnnexMessage = insertGitAnnexTag silentMessage
+gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
+	{ messageTo = Just tojid
+	, messageFrom = Just fromjid
+	}
 
 {- A notification that we've pushed to some repositories, listing their
  - UUIDs. -}
@@ -75,10 +87,10 @@ pushNotification :: [UUID] -> Presence
 pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
 
 pushAttr :: Name
-pushAttr = Name (T.pack "push") Nothing Nothing
+pushAttr = "push"
 
-uuidSep :: T.Text
+uuidSep :: Text
-uuidSep = T.pack ","
+uuidSep = ","
 
 encodePushNotification :: [UUID] -> Text
 encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
@@ -91,21 +103,15 @@ presenceQuery :: Presence
 presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
 
 queryAttr :: Name
-queryAttr = Name (T.pack "query") Nothing Nothing
+queryAttr = "query"
 
 {- A notification about a stage of pairing. -}
 pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
-pairingNotification pairstage u tojid fromjid =
+pairingNotification pairstage u = gitAnnexMessage $ 
-	(gitAnnexMessage tag)
+	gitAnnexTag pairAttr $ encodePairingNotification pairstage u
-		{ messageTo = Just tojid
-		, messageFrom = Just fromjid
-		}
-  where
-	tag = gitAnnexTag pairAttr $
-		encodePairingNotification pairstage u
 
 pairAttr :: Name
-pairAttr = Name (T.pack "pair") Nothing Nothing
+pairAttr = "pair"
 
 encodePairingNotification :: PairStage -> UUID -> Text
 encodePairingNotification pairstage u = T.unwords $ map T.pack
@@ -122,6 +128,57 @@ decodePairingNotification t msg = parse $ words $ T.unpack t
 		<*> pure (toUUID u)
 	parse _ = Nothing
 
+pushRequest :: JID -> JID -> Message
+pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
+
+pushRequestAttr :: Name
+pushRequestAttr = "pushrequest"
+
+startingPush :: JID -> JID -> Message
+startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
+
+startingPushAttr :: Name
+startingPushAttr = "startingpush"
+
+receivePackOutput :: ByteString -> JID -> JID -> Message
+receivePackOutput = gitAnnexMessage .
+	gitAnnexTagContent receivePackAttr T.empty . encodeTagContent
+
+receivePackAttr :: Name
+receivePackAttr = "rp"
+
+sendPackOutput :: ByteString -> JID -> JID -> Message
+sendPackOutput = gitAnnexMessage .
+	gitAnnexTagContent sendPackAttr T.empty . encodeTagContent
+
+sendPackAttr :: Name
+sendPackAttr = "sp"
+
+receivePackDone :: ExitCode -> JID -> JID -> Message
+receivePackDone = gitAnnexMessage . gitAnnexTag receivePackAttr . T.pack . show . toi
+  where
+	toi (ExitSuccess) = 0
+	toi (ExitFailure i) = i
+
+decodeReceivePackDone :: Text -> ExitCode
+decodeReceivePackDone t = fromMaybe (ExitFailure 1) $
+	fromi <$> readish (T.unpack t)
+  where
+	fromi 0 = ExitSuccess
+	fromi i = ExitFailure i
+
+receivePackDoneAttr :: Name
+receivePackDoneAttr = "rpdone"
+
+{- Base 64 encoding a ByteString to use as the content of a tag. -}
+encodeTagContent :: ByteString -> [Node]
+encodeTagContent b = [NodeContent $ ContentText $ T.pack $ B64.encode $ B.unpack b]
+
+decodeTagContent :: Element -> Maybe ByteString
+decodeTagContent elt = B.pack <$> B64.decode s
+  where
+	s = T.unpack $ T.concat $ elementText elt
+
 {- The JID without the client part. -}
 baseJID :: JID -> JID
 baseJID j = JID (jidNode j) (jidDomain j) Nothing
@@ -133,12 +190,11 @@ silentMessage = (emptyMessage MessageChat)
 	{ messagePayloads = [ emptybody ] }
   where
 	emptybody = Element
-		{ elementName = Name (T.pack "body") Nothing Nothing
+		{ elementName = "body"
 		, elementAttributes = []
 		, elementNodes = []
 		}
 
 {- Add to a presence to mark its client as extended away. -}
 extendedAway :: Element
-extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
+extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
-	[NodeContent $ ContentText $ T.pack "xa"]

doc/design/assistant/xmpp.mdwn

@@ -58,7 +58,7 @@ For pairing, a chat message is sent, containing:
 
 To request that a peer push to us, a chat message can be sent:
 
-	<git-annex xmlns='git-annex' startpush="" />
+	<git-annex xmlns='git-annex' pushrequest="" />
 
 When a peer is ready to send a git push, it sends:
 
@@ -67,11 +67,15 @@ When a peer is ready to send a git push, it sends:
 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" />
+	<git-annex xmlns='git-annex' rp="">
+	007b27ca394d26a05d9b6beefa1b07da456caa2157d7 refs/heads/git-annex report-status delete-refs side-band-64k quiet ofs-delta
+	</git-annex>
 
 The sender replies with the data from `git push`:
 
-	<git-annex xmlns='git-annex' sp="data" />
+	<git-annex xmlns='git-annex' sp="">
+	data
+	</git-annex>
 
 When `git receive-pack` edits, the receiver indicates its exit
 status: