add two long-running XMPP push threads, no more inversion of control

I hope this will be easier to reason about, and less buggy. It was
certianly easier to write!

An immediate benefit is that with a traversable queue of push requests to
select from, the threads can be a lot fairer about choosing which client to
service next.
This commit is contained in:
Joey Hess 2013-05-22 15:13:31 -04:00
parent 52371274f0
commit e2b67e0bc4
7 changed files with 166 additions and 107 deletions

View file

@ -101,7 +101,7 @@ makeXMPPGitRemote buddyname jid u = do
- We listen at the other end of the pipe and relay to and from XMPP.
-}
xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
xmppPush cid gitpush = runPush SendPack cid $ do
xmppPush cid gitpush = do
u <- liftAnnex getUUID
sendNetMessage $ Pushing cid (StartingPush u)
@ -239,7 +239,7 @@ xmppGitRelay = 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 = runPush ReceivePack cid $ do
xmppReceivePack cid = do
repodir <- liftAnnex $ fromRepo repoPath
let p = (proc "git" ["receive-pack", repodir])
{ std_in = CreatePipe
@ -288,11 +288,12 @@ xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
matching loc r = repoIsUrl r && repoLocation r == loc
knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant ()
handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
{- Returns the ClientID that it pushed to. -}
runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
go =<< liftAnnex (inRepo Git.Branch.current)
where
go Nothing = noop
go Nothing = return Nothing
go (Just branch) = do
rs <- xmppRemotes cid theiruuid
liftAnnex $ Annex.Branch.commit "update"
@ -301,17 +302,24 @@ handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
<*> getUUID
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
forM_ rs $ \r -> do
void $ alertWhile (syncAlert [r]) $
xmppPush cid (taggedPush u selfjid branch r)
checkcloudrepos r
handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
if null rs
then return Nothing
else do
forM_ rs $ \r -> do
void $ alertWhile (syncAlert [r]) $
xmppPush cid (taggedPush u selfjid branch r)
checkcloudrepos r
return $ Just cid
runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
rs <- xmppRemotes cid theiruuid
unless (null rs) $ do
void $ alertWhile (syncAlert rs) $
xmppReceivePack cid
mapM_ checkcloudrepos rs
handlePushInitiation _ _ = noop
if null rs
then return Nothing
else do
void $ alertWhile (syncAlert rs) $
xmppReceivePack cid
mapM_ checkcloudrepos rs
return $ Just cid
runPush _ _ = return Nothing
{- Check if any of the shas that can be pushed are ones we do not
- have.
@ -370,4 +378,3 @@ extractSequence :: NetMessage -> Maybe Int
extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum
extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum
extractSequence _ = Nothing