aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/Types/NetMessager.hs11
-rw-r--r--Assistant/XMPP.hs98
-rw-r--r--doc/design/assistant/xmpp.mdwn10
3 files changed, 95 insertions, 24 deletions
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index f84247d6c..aa0585590 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/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
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 48357bd61..de76d8e6e 100644
--- a/Assistant/XMPP.hs
+++ b/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 = insertGitAnnexTag silentMessage
+gitAnnexMessage :: Element -> JID -> JID -> Message
+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 = T.pack ","
+uuidSep :: Text
+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 =
- (gitAnnexMessage tag)
- { messageTo = Just tojid
- , messageFrom = Just fromjid
- }
- where
- tag = gitAnnexTag pairAttr $
- encodePairingNotification pairstage u
+pairingNotification pairstage u = gitAnnexMessage $
+ 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) []
- [NodeContent $ ContentText $ T.pack "xa"]
+extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn
index 84d3a5c0e..dafa709db 100644
--- a/doc/design/assistant/xmpp.mdwn
+++ b/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:
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 12:24:46 +0000