From 0238e4ba072fb7b99666ccbd4082d5634b0c8a50 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Nov 2012 14:02:37 -0400 Subject: [PATCH] hooked up XMPP git push send/receive (but not yet control flow) --- Assistant/Threads/XMPPClient.hs | 60 +++++++++++++++++++++------------ Assistant/Types/NetMessager.hs | 19 ++++++----- Assistant/XMPP.hs | 35 ++++++++++++++----- Assistant/XMPP/Git.hs | 23 ++++++++----- doc/design/assistant/xmpp.mdwn | 7 ++-- 5 files changed, 95 insertions(+), 49 deletions(-) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 7da2bccc63..1117c3c140 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -52,7 +52,7 @@ xmppClient urlrenderer d = do Just c -> retry (runclient c) =<< getCurrentTime where liftAssistant = runAssistant d - xAssistant = liftIO . liftAssistant + inAssistant = liftIO . liftAssistant {- When the client exits, it's restarted; - if it keeps failing, back off to wait 5 minutes before @@ -73,30 +73,35 @@ xmppClient urlrenderer d = do selfjid <- bindJID jid putStanza gitAnnexSignature - xAssistant $ debug ["connected", show selfjid] + inAssistant $ debug ["connected", show selfjid] {- The buddy list starts empty each time - the client connects, so that stale info - is not retained. -} - void $ xAssistant $ + void $ inAssistant $ updateBuddyList (const noBuddies) <<~ buddyList xmppThread $ receivenotifications selfjid forever $ do - a <- xAssistant $ relayNetMessage selfjid + a <- inAssistant $ relayNetMessage selfjid a receivenotifications selfjid = forever $ do l <- decodeStanza selfjid <$> getStanza - xAssistant $ debug ["received:", show l] + inAssistant $ debug ["received:", show l] mapM_ (handle selfjid) l - handle _ (PresenceMessage p) = void $ xAssistant $ + handle _ (PresenceMessage p) = void $ inAssistant $ updateBuddyList (updateBuddies p) <<~ buddyList handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature - handle _ (GotNetMessage (NotifyPush us)) = void $ xAssistant $ + handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us - handle selfjid (GotNetMessage (PairingNotification stage t u)) = - maybe noop (xAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID t) + handle selfjid (GotNetMessage (PairingNotification stage c u)) = + maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) + handle selfjid (GotNetMessage (PushRequest c)) = error "TODO" + handle selfjid (GotNetMessage (StartingPush c)) = error "TODO" + handle selfjid (GotNetMessage (ReceivePackOutput c b)) = error "TODO" + handle selfjid (GotNetMessage (SendPackOutput c b)) = error "TODO" + handle selfjid (GotNetMessage (ReceivePackDone c code)) = error "TODO" handle _ (Ignorable _) = noop handle _ (Unknown _) = noop handle _ (ProtocolError _) = noop @@ -117,7 +122,7 @@ decodeStanza selfjid s@(ReceivedPresence p) | presenceFrom p == Just selfjid = [Ignorable s] | otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p) where - decode (attr, v) + decode (attr, v, _tag) | attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ decodePushNotification v | attr == queryAttr = impliedp $ GotNetMessage QueryPresence @@ -131,10 +136,15 @@ decodeStanza selfjid s@(ReceivedMessage m) | messageType m == MessageError = [ProtocolError s] | otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m) where - decode (attr, v) - | attr == pairAttr = - [maybe (Unknown s) GotNetMessage (decodePairingNotification v m)] + decode (attr, v, tag) + | attr == pairAttr = use $ decodePairingNotification v + | attr == pushRequestAttr = use decodePushRequest + | attr == startingPushAttr = use decodeStartingPush + | attr == receivePackAttr = use $ decodeReceivePackOutput tag + | attr == sendPackAttr = use $ decodeSendPackOutput tag + | attr == receivePackDoneAttr = use $ decodeReceivePackDone v | otherwise = [Unknown s] + use v = [maybe (Unknown s) GotNetMessage (v m)] decodeStanza _ s = [Unknown s] {- Waits for a NetMessager message to be sent, and relays it to XMPP. -} @@ -142,15 +152,23 @@ relayNetMessage :: JID -> Assistant (XMPP ()) relayNetMessage selfjid = convert =<< waitNetMessage where convert (NotifyPush us) = return $ putStanza $ pushNotification us - convert QueryPresence = return $ putStanza $ presenceQuery - convert (PairingNotification stage t u) = case parseJID t of - Nothing -> return $ noop + convert QueryPresence = return $ putStanza presenceQuery + convert (PairingNotification stage c u) = withclient c $ \tojid -> do + changeBuddyPairing tojid True + return $ putStanza $ pairingNotification stage u tojid selfjid + convert (PushRequest c) = sendclient c pushRequest + convert (StartingPush c) = sendclient c startingPush + convert (ReceivePackOutput c b) = sendclient c $ receivePackOutput b + convert (SendPackOutput c b) = sendclient c $ sendPackOutput b + convert (ReceivePackDone c code) = sendclient c $ receivePackDone code + + sendclient c construct = withclient c $ \tojid -> + return $ putStanza $ construct tojid selfjid + withclient c a = case parseJID c of + Nothing -> return noop Just tojid - | tojid == selfjid -> return $ noop - | otherwise -> do - changeBuddyPairing tojid True - return $ putStanza $ - pairingNotification stage u tojid selfjid + | tojid == selfjid -> return noop + | otherwise -> a tojid {- Runs a XMPP action in a separate thread, using a session to allow it - to access the same XMPP client. -} diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index aa05855908..163468744e 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -22,20 +22,23 @@ data NetMessage -- requests other clients to inform us of their presence | QueryPresence -- notification about a stage in the pairing process, - -- involving a client identified by the Text, and a UUID. - | PairingNotification PairStage Text UUID + -- involving a client, and a UUID. + | PairingNotification PairStage ClientID 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 + | PushRequest ClientID + -- indicates that a push is starting + | StartingPush ClientID -- a chunk of output of git receive-pack - | ReceivePackOutput ByteString + | ReceivePackOutput ClientID ByteString -- a chuck of output of git send-pack - | SendPackOutput ByteString + | SendPackOutput ClientID ByteString -- sent when git receive-pack exits, with its exit code - | ReceivePackDone ExitCode + | ReceivePackDone ClientID ExitCode deriving (Show) +{- Something used to identify a specific client to send the message to. -} +type ClientID = Text + data NetMessagerControl = NetMessagerControl { netMessages :: TChan (NetMessage) , netMessagerRestart :: MSampleVar () diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index de76d8e6e1..104915b81e 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 diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index f7ae64c8de..7c4509c51e 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -8,6 +8,8 @@ module Assistant.XMPP.Git where import Assistant.Common +import Assistant.NetMessager +import Assistant.Types.NetMessager import Assistant.XMPP import Assistant.XMPP.Buddies import Assistant.DaemonStatus @@ -77,7 +79,10 @@ makeXMPPGitRemote buddyname jid u = do - We listen at the other end of the pipe and relay to and from XMPP. -} xmppPush :: Remote -> [Ref] -> Assistant Bool -xmppPush remote refs = do +xmppPush remote refs = error "TODO" + +xmppPush' :: ClientID -> Remote -> [Ref] -> Assistant Bool +xmppPush' cid remote refs = do program <- liftIO readProgramFile (Fd inf, writepush) <- liftIO createPipe @@ -115,7 +120,7 @@ xmppPush remote refs = do b <- liftIO $ B.hGetSome inh 1024 when (B.null b) $ liftIO $ killThread =<< myThreadId - -- TODO relay b to xmpp + sendNetMessage $ SendPackOutput cid b error "TODO" fromxmpp outh = forever $ do -- TODO get b from xmpp @@ -168,12 +173,13 @@ xmppGitRelay = do | otherwise -> ExitFailure n Nothing -> ExitFailure 1 -{- Relays git receive-pack to and from XMPP, and propigates its exit status. -} -xmppReceivePack :: Assistant Bool -xmppReceivePack = do +{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating + - its exit status to XMPP. -} +xmppReceivePack :: ClientID -> Assistant Bool +xmppReceivePack cid = do feeder <- asIO1 toxmpp reader <- asIO1 fromxmpp - controller <- asIO1 controlxmpp + sendexitcode <- asIO1 $ sendNetMessage . ReceivePackDone cid repodir <- liftAnnex $ fromRepo repoPath let p = (proc "git" ["receive-pack", repodir]) { std_in = CreatePipe @@ -185,7 +191,7 @@ xmppReceivePack = do feedertid <- forkIO $ feeder outh void $ reader inh code <- waitForProcess pid - void $ controller code + void $ sendexitcode code killThread feedertid return $ code == ExitSuccess where @@ -194,7 +200,6 @@ xmppReceivePack = do if B.null b then return () -- EOF else do - error "TODO feed b to xmpp" + sendNetMessage $ ReceivePackOutput cid b toxmpp outh fromxmpp _inh = error "TODO feed xmpp to inh" - controlxmpp _code = error "TODO propigate exit code" diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index dafa709db9..a7370382e1 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -58,11 +58,11 @@ For pairing, a chat message is sent, containing: To request that a peer push to us, a chat message can be sent: - + 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: @@ -71,7 +71,8 @@ one or more chat messages: 007b27ca394d26a05d9b6beefa1b07da456caa2157d7 refs/heads/git-annex report-status delete-refs side-band-64k quiet ofs-delta -The sender replies with the data from `git push`: +The sender replies with the data from `git push` (which does not need +to actually be started until this point): data