hooked up XMPP git push send/receive (but not yet control flow)

1 files changed, 27 insertions, 8 deletions

diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index de76d8e6e..104915b81 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -55,14 +55,16 @@ instance GitAnnexTaggable Presence where
 	insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p }
 	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
 
-{- Gets the attr and its value value from a git-annex tag.
+{- Gets the attr and its value value from a git-annex tag, as well as the
+ - tag.
  -
  - Each git-annex tag has a single attribute. -}
-getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text)
+getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text, Element)
 getGitAnnexAttrValue a = case extractGitAnnexTag a of
-	Just (tag@(Element _ [(attr, _)] _)) -> (,)
+	Just (tag@(Element _ [(attr, _)] _)) -> (,,)
 		<$> pure attr
 		<*> attributeText attr tag
+		<*> pure tag
 	_ -> Nothing
 
 {- A presence with a git-annex tag in it. -}
@@ -120,17 +122,20 @@ encodePairingNotification pairstage u = T.unwords $ map T.pack
 	]
 
 decodePairingNotification :: Text -> Message -> Maybe NetMessage
-decodePairingNotification t msg = parse $ words $ T.unpack t
+decodePairingNotification t m = parse $ words $ T.unpack t
   where
 	parse [stage, u] = PairingNotification
 		<$> readish stage
-		<*> (formatJID <$> messageFrom msg)
+		<*> (formatJID <$> messageFrom m)
 		<*> pure (toUUID u)
 	parse _ = Nothing
 
 pushRequest :: JID -> JID -> Message
 pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
 
+decodePushRequest :: Message -> Maybe NetMessage
+decodePushRequest m = PushRequest <$> (formatJID <$> messageFrom m)
+
 pushRequestAttr :: Name
 pushRequestAttr = "pushrequest"
 
@@ -140,6 +145,9 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
 startingPushAttr :: Name
 startingPushAttr = "startingpush"
 
+decodeStartingPush :: Message -> Maybe NetMessage
+decodeStartingPush m = StartingPush <$> (formatJID <$> messageFrom m)
+
 receivePackOutput :: ByteString -> JID -> JID -> Message
 receivePackOutput = gitAnnexMessage .
 	gitAnnexTagContent receivePackAttr T.empty . encodeTagContent
@@ -147,6 +155,11 @@ receivePackOutput = gitAnnexMessage .
 receivePackAttr :: Name
 receivePackAttr = "rp"
 
+decodeReceivePackOutput :: Element -> Message -> Maybe NetMessage
+decodeReceivePackOutput t m = ReceivePackOutput
+	<$> (formatJID <$> messageFrom m)
+	<*> decodeTagContent t
+
 sendPackOutput :: ByteString -> JID -> JID -> Message
 sendPackOutput = gitAnnexMessage .
 	gitAnnexTagContent sendPackAttr T.empty . encodeTagContent
@@ -154,15 +167,21 @@ sendPackOutput = gitAnnexMessage .
 sendPackAttr :: Name
 sendPackAttr = "sp"
 
+decodeSendPackOutput :: Element -> Message -> Maybe NetMessage
+decodeSendPackOutput t m = SendPackOutput
+	<$> (formatJID <$> messageFrom m)
+	<*> decodeTagContent t
+
 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)
+decodeReceivePackDone :: Text -> Message -> Maybe NetMessage
+decodeReceivePackDone t m = ReceivePackDone
+	<$> (formatJID <$> messageFrom m)
+	<*> (fromi <$> readish (T.unpack t))
   where
 	fromi 0 = ExitSuccess
 	fromi i = ExitFailure i