summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/NetMessager.hs22
-rw-r--r--Assistant/Sync.hs7
-rw-r--r--Assistant/Threads/XMPPClient.hs36
-rw-r--r--Assistant/Types/NetMessager.hs48
-rw-r--r--Assistant/XMPP.hs161
-rw-r--r--Assistant/XMPP/Git.hs29
6 files changed, 145 insertions, 158 deletions
diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs
index ab1c6aabe..5a2746cc7 100644
--- a/Assistant/NetMessager.hs
+++ b/Assistant/NetMessager.hs
@@ -74,17 +74,19 @@ queueNetPushMessage m = do
running <- readTMVar (netMessagerPushRunning nm)
case running of
NoPushRunning -> return False
- SendPushRunning cid -> go nm cid
- ReceivePushRunning cid -> go nm cid
+ SendPushRunning runningcid -> do
+ go nm m runningcid
+ return True
+ ReceivePushRunning runningcid -> do
+ go nm m runningcid
+ return True
where
- go nm cid
- | getClientID m == Just cid = do
- writeTChan (netMessagesPush nm) m
- return True
- | otherwise = do
- when (isPushInitiationMessage m) $
- defer nm
- return True
+ go nm (Pushing cid stage) runningcid
+ | cid == runningcid = writeTChan (netMessagesPush nm) m
+ | isPushInitiation stage = defer nm
+ | otherwise = noop
+ go _ _ _ = noop
+
defer nm = do
s <- takeTMVar (netMessagesDeferredPush nm)
putTMVar (netMessagesDeferredPush nm) $ S.insert m s
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 97fcc88ce..201e6e534 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -98,9 +98,10 @@ pushToRemotes now notifypushes remotes = do
<*> inRepo Git.Branch.current
<*> getUUID
let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
- r <- go True branch g u normalremotes
- mapM_ (sendNetMessage . CanPush . getXMPPClientID) xmppremotes
- return r
+ ret <- go True branch g u normalremotes
+ forM_ xmppremotes $ \r ->
+ sendNetMessage $ Pushing (getXMPPClientID r) CanPush
+ return ret
where
go _ Nothing _ _ _ = return True -- no branch, so nothing to do
go shouldretry (Just branch) g u rs = do
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 6b6c14ea5..ee1db0666 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -96,11 +96,11 @@ xmppClient urlrenderer d = do
handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
handle selfjid (GotNetMessage (PairingNotification stage c u)) =
maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
- handle _ (GotNetMessage pushmsg)
- | isPushInitiationMessage pushmsg = inAssistant $
- unlessM (queueNetPushMessage pushmsg) $
- void $ forkIO <~> handlePushMessage pushmsg
- | otherwise = void $ inAssistant $ queueNetPushMessage pushmsg
+ handle _ (GotNetMessage m@(Pushing _ pushstage))
+ | isPushInitiation pushstage = inAssistant $
+ unlessM (queueNetPushMessage m) $
+ void $ forkIO <~> handlePushMessage m
+ | otherwise = void $ inAssistant $ queueNetPushMessage m
handle _ (Ignorable _) = noop
handle _ (Unknown _) = noop
handle _ (ProtocolError _) = noop
@@ -134,19 +134,7 @@ decodeStanza selfjid s@(ReceivedMessage m)
| messageFrom m == Nothing = [Ignorable s]
| messageFrom m == Just selfjid = [Ignorable s]
| messageType m == MessageError = [ProtocolError s]
- | otherwise = [fromMaybe (Unknown s) $ decode =<< gitAnnexTagInfo m]
- where
- decode i = GotNetMessage <$>
- ((\d -> d m i) =<< M.lookup (tagAttr i) decoders)
- decoders = M.fromList
- [ (pairAttr, decodePairingNotification)
- , (canPushAttr, decodeCanPush)
- , (pushRequestAttr, decodePushRequest)
- , (startingPushAttr, decodeStartingPush)
- , (receivePackAttr, decodeReceivePackOutput)
- , (sendPackAttr, decodeSendPackOutput)
- , (receivePackDoneAttr, decodeReceivePackDone)
- ]
+ | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
@@ -158,15 +146,9 @@ relayNetMessage selfjid = convert =<< waitNetMessage
convert (PairingNotification stage c u) = withclient c $ \tojid -> do
changeBuddyPairing tojid True
return $ putStanza $ pairingNotification stage u tojid selfjid
- convert (CanPush c) = sendclient c canPush
- 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
+ convert (Pushing c pushstage) = withclient c $ \tojid ->
+ return $ putStanza $ pushMessage pushstage tojid selfjid
+
withclient c a = case parseJID c of
Nothing -> return noop
Just tojid
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index d2195f53c..091d12815 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -25,39 +25,36 @@ data NetMessage
-- notification about a stage in the pairing process,
-- involving a client, and a UUID.
| PairingNotification PairStage ClientID UUID
+ -- used for git push over the network messager
+ | Pushing ClientID PushStage
+ deriving (Show, Eq, Ord)
+
+{- Something used to identify the client, or clients to send the message to. -}
+type ClientID = Text
+
+data PushStage
-- indicates that we have data to push over the out of band network
- | CanPush ClientID
+ = CanPush
-- request that a git push be sent over the out of band network
- | PushRequest ClientID
+ | PushRequest
-- indicates that a push is starting
- | StartingPush ClientID
+ | StartingPush
-- a chunk of output of git receive-pack
- | ReceivePackOutput ClientID ByteString
+ | ReceivePackOutput ByteString
-- a chuck of output of git send-pack
- | SendPackOutput ClientID ByteString
+ | SendPackOutput ByteString
-- sent when git receive-pack exits, with its exit code
- | ReceivePackDone ClientID ExitCode
+ | ReceivePackDone ExitCode
deriving (Show, Eq, Ord)
-{- Something used to identify the client, or clients to send the message to. -}
-type ClientID = Text
-
-getClientID :: NetMessage -> Maybe ClientID
-getClientID (NotifyPush _) = Nothing
-getClientID QueryPresence = Nothing
-getClientID (PairingNotification _ cid _) = Just cid
-getClientID (CanPush cid) = Just cid
-getClientID (PushRequest cid) = Just cid
-getClientID (StartingPush cid) = Just cid
-getClientID (ReceivePackOutput cid _) = Just cid
-getClientID (SendPackOutput cid _) = Just cid
-getClientID (ReceivePackDone cid _) = Just cid
+data PushRunning = NoPushRunning | SendPushRunning ClientID | ReceivePushRunning ClientID
+ deriving (Eq)
-isPushInitiationMessage :: NetMessage -> Bool
-isPushInitiationMessage (CanPush _) = True
-isPushInitiationMessage (PushRequest _) = True
-isPushInitiationMessage (StartingPush _) = True
-isPushInitiationMessage _ = False
+isPushInitiation :: PushStage -> Bool
+isPushInitiation CanPush = True
+isPushInitiation PushRequest = True
+isPushInitiation StartingPush = True
+isPushInitiation _ = False
data NetMessager = NetMessager
-- outgoing messages
@@ -72,9 +69,6 @@ data NetMessager = NetMessager
, netMessagerRestart :: MSampleVar ()
}
-data PushRunning = NoPushRunning | SendPushRunning ClientID | ReceivePushRunning ClientID
- deriving (Eq)
-
newNetMessager :: IO NetMessager
newNetMessager = NetMessager
<$> atomically newTChan
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 5532b8027..d31712770 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -16,6 +16,7 @@ import Assistant.Pairing
import Network.Protocol.XMPP hiding (Node)
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.XML.Types
@@ -61,6 +62,8 @@ data GitAnnexTagInfo = GitAnnexTagInfo
, tagElement :: Element
}
+type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
+
gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
gitAnnexTagInfo v = case extractGitAnnexTag v of
{- Each git-annex tag has a single attribute. -}
@@ -91,40 +94,31 @@ gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
pushNotification :: [UUID] -> Presence
pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
-pushAttr :: Name
-pushAttr = "push"
-
-uuidSep :: Text
-uuidSep = ","
-
encodePushNotification :: [UUID] -> Text
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
decodePushNotification :: Text -> [UUID]
decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
+uuidSep :: Text
+uuidSep = ","
+
{- A request for other git-annex clients to send presence. -}
presenceQuery :: Presence
presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
-queryAttr :: Name
-queryAttr = "query"
-
{- A notification about a stage of pairing. -}
pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
pairingNotification pairstage u = gitAnnexMessage $
gitAnnexTag pairAttr $ encodePairingNotification pairstage u
-pairAttr :: Name
-pairAttr = "pair"
-
encodePairingNotification :: PairStage -> UUID -> Text
encodePairingNotification pairstage u = T.unwords $ map T.pack
[ show pairstage
, fromUUID u
]
-decodePairingNotification :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodePairingNotification :: Decoder
decodePairingNotification m = parse . words . T.unpack . tagValue
where
parse [stage, u] = PairingNotification
@@ -133,73 +127,57 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
<*> pure (toUUID u)
parse _ = Nothing
-canPush :: JID -> JID -> Message
-canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
-
-decodeCanPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodeCanPush m _ = CanPush <$> (formatJID <$> messageFrom m)
-
-canPushAttr :: Name
-canPushAttr = "canpush"
-
-pushRequest :: JID -> JID -> Message
-pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
-
-decodePushRequest :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodePushRequest m _ = PushRequest <$> (formatJID <$> messageFrom m)
-
-pushRequestAttr :: Name
-pushRequestAttr = "pushrequest"
-
-startingPush :: JID -> JID -> Message
-startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
-
-startingPushAttr :: Name
-startingPushAttr = "startingpush"
-
-decodeStartingPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodeStartingPush m _ = StartingPush <$> (formatJID <$> messageFrom m)
-
-receivePackOutput :: ByteString -> JID -> JID -> Message
-receivePackOutput = gitAnnexMessage .
- gitAnnexTagContent receivePackAttr T.empty . encodeTagContent
-
-receivePackAttr :: Name
-receivePackAttr = "rp"
-
-decodeReceivePackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodeReceivePackOutput m i = ReceivePackOutput
- <$> (formatJID <$> messageFrom m)
- <*> decodeTagContent (tagElement i)
-
-sendPackOutput :: ByteString -> JID -> JID -> Message
-sendPackOutput = gitAnnexMessage .
- gitAnnexTagContent sendPackAttr T.empty . encodeTagContent
-
-sendPackAttr :: Name
-sendPackAttr = "sp"
-
-decodeSendPackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodeSendPackOutput m i = SendPackOutput
- <$> (formatJID <$> messageFrom m)
- <*> decodeTagContent (tagElement i)
-
-receivePackDone :: ExitCode -> JID -> JID -> Message
-receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . show . toi
+pushMessage :: PushStage -> JID -> JID -> Message
+pushMessage = gitAnnexMessage . encode
where
- toi (ExitSuccess) = 0
- toi (ExitFailure i) = i
-
-decodeReceivePackDone :: Message -> GitAnnexTagInfo -> Maybe NetMessage
-decodeReceivePackDone m i = ReceivePackDone
- <$> (formatJID <$> messageFrom m)
- <*> (convert <$> readish (T.unpack $ tagValue i))
+ encode CanPush = gitAnnexTag canPushAttr T.empty
+ encode PushRequest = gitAnnexTag pushRequestAttr T.empty
+ encode StartingPush = gitAnnexTag startingPushAttr T.empty
+ encode (ReceivePackOutput b) =
+ gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
+ encode (SendPackOutput b) =
+ gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
+ encode (ReceivePackDone code) =
+ gitAnnexTag receivePackDoneAttr $
+ T.pack $ show $ encodeExitCode code
+
+decodeMessage :: Message -> Maybe NetMessage
+decodeMessage m = decode =<< gitAnnexTagInfo m
where
- convert 0 = ExitSuccess
- convert n = ExitFailure n
-
-receivePackDoneAttr :: Name
-receivePackDoneAttr = "rpdone"
+ decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
+ rundecoder i d = d m i
+ decoders = M.fromList $ zip
+ [ pairAttr
+ , canPushAttr
+ , pushRequestAttr
+ , startingPushAttr
+ , receivePackAttr
+ , sendPackAttr
+ , receivePackDoneAttr
+ ]
+ [ decodePairingNotification
+ , pushdecoder $ const $ Just CanPush
+ , pushdecoder $ const $ Just PushRequest
+ , pushdecoder $ const $ Just StartingPush
+ , pushdecoder $
+ fmap ReceivePackOutput . decodeTagContent . tagElement
+ , pushdecoder $
+ fmap SendPackOutput . decodeTagContent . tagElement
+ , pushdecoder $
+ fmap (ReceivePackDone . decodeExitCode) . readish .
+ T.unpack . tagValue
+ ]
+ pushdecoder a m i = Pushing
+ <$> (formatJID <$> messageFrom m)
+ <*> a i
+
+decodeExitCode :: Int -> ExitCode
+decodeExitCode 0 = ExitSuccess
+decodeExitCode n = ExitFailure n
+
+encodeExitCode :: ExitCode -> Int
+encodeExitCode ExitSuccess = 0
+encodeExitCode (ExitFailure n) = n
{- Base 64 encoding a ByteString to use as the content of a tag. -}
encodeTagContent :: ByteString -> [Node]
@@ -229,3 +207,30 @@ silentMessage = (emptyMessage MessageChat)
{- Add to a presence to mark its client as extended away. -}
extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
+
+pushAttr :: Name
+pushAttr = "push"
+
+queryAttr :: Name
+queryAttr = "query"
+
+pairAttr :: Name
+pairAttr = "pair"
+
+canPushAttr :: Name
+canPushAttr = "canpush"
+
+pushRequestAttr :: Name
+pushRequestAttr = "pushrequest"
+
+startingPushAttr :: Name
+startingPushAttr = "startingpush"
+
+receivePackAttr :: Name
+receivePackAttr = "rp"
+
+sendPackAttr :: Name
+sendPackAttr = "sp"
+
+receivePackDoneAttr :: Name
+receivePackDoneAttr = "rpdone"
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 49d3bedcc..86c9c9a9b 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -74,7 +74,7 @@ makeXMPPGitRemote buddyname jid u = do
-}
xmppPush :: ClientID -> Remote -> [Ref] -> Assistant Bool
xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
- sendNetMessage $ StartingPush cid
+ sendNetMessage $ Pushing cid StartingPush
(Fd inf, writepush) <- liftIO createPipe
(readpush, Fd outf) <- liftIO createPipe
@@ -118,14 +118,16 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
b <- liftIO $ B.hGetSome inh chunkSize
if B.null b
then liftIO $ killThread =<< myThreadId
- else sendNetMessage $ SendPackOutput cid b
+ else sendNetMessage $ Pushing cid $ SendPackOutput b
fromxmpp outh controlh = forever $ do
m <- waitNetPushMessage
case m of
- (ReceivePackOutput _ b) -> liftIO $ writeChunk outh b
- (ReceivePackDone _ exitcode) -> liftIO $ do
- hPrint controlh exitcode
- hFlush controlh
+ (Pushing _ (ReceivePackOutput b)) ->
+ liftIO $ writeChunk outh b
+ (Pushing _ (ReceivePackDone exitcode)) ->
+ liftIO $ do
+ hPrint controlh exitcode
+ hFlush controlh
_ -> noop
installwrapper tmpdir = liftIO $ do
createDirectoryIfMissing True tmpdir
@@ -197,7 +199,7 @@ xmppReceivePack cid = runPush (ReceivePushRunning cid) handleDeferred $ do
readertid <- forkIO <~> relayfromxmpp inh
relaytoxmpp outh
code <- liftIO $ waitForProcess pid
- void $ sendNetMessage $ ReceivePackDone cid code
+ void $ sendNetMessage $ Pushing cid $ ReceivePackDone code
liftIO $ do
killThread readertid
hClose inh
@@ -208,12 +210,13 @@ xmppReceivePack cid = runPush (ReceivePushRunning cid) handleDeferred $ do
b <- liftIO $ B.hGetSome outh chunkSize
-- empty is EOF, so exit
unless (B.null b) $ do
- sendNetMessage $ ReceivePackOutput cid b
+ sendNetMessage $ Pushing cid $ ReceivePackOutput b
relaytoxmpp outh
relayfromxmpp inh = forever $ do
m <- waitNetPushMessage
case m of
- (SendPackOutput _ b) -> liftIO $ writeChunk inh b
+ (Pushing _ (SendPackOutput b)) ->
+ liftIO $ writeChunk inh b
_ -> noop
xmppRemotes :: ClientID -> Assistant [Remote]
@@ -230,15 +233,15 @@ whenXMPPRemote :: ClientID -> Assistant () -> Assistant ()
whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid)
handlePushMessage :: NetMessage -> Assistant ()
-handlePushMessage (CanPush cid) = whenXMPPRemote cid $
- sendNetMessage $ PushRequest cid
-handlePushMessage (PushRequest cid) = do
+handlePushMessage (Pushing cid CanPush) = whenXMPPRemote cid $
+ sendNetMessage $ Pushing cid PushRequest
+handlePushMessage (Pushing cid PushRequest) = do
rs <- xmppRemotes cid
current <- liftAnnex $ inRepo Git.Branch.current
--let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO
let refs = [Ref "master:refs/remotes/xmpp/newmaster"]
forM_ rs $ \r -> xmppPush cid r refs
-handlePushMessage (StartingPush cid) = whenXMPPRemote cid $
+handlePushMessage (Pushing cid StartingPush) = whenXMPPRemote cid $
void $ xmppReceivePack cid
handlePushMessage _ = noop
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-08 04:09:41 +0000