diff options
| -rw-r--r-- | Assistant/XMPP/Git.hs | 164 |
1 files changed, 75 insertions, 89 deletions
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 904076134..49d3bedcc 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -42,14 +42,16 @@ finishXMPPPairing jid u = void $ alertWhile alert $ buddy = T.unpack $ buddyName jid alert = pairRequestAcknowledgedAlert buddy Nothing +gitXMPPLocation :: JID -> String +gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid) + makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool makeXMPPGitRemote buddyname jid u = do - remote <- liftAnnex $ addRemote $ makeGitRemote buddyname xmppaddress + remote <- liftAnnex $ addRemote $ + makeGitRemote buddyname $ gitXMPPLocation jid liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u syncNewRemote remote return True - where - xmppaddress = "xmpp::" ++ T.unpack (formatJID $ baseJID jid) {- Pushes the named refs to the remote, over XMPP, communicating with a - specific client that either requested the push, or responded to our @@ -64,11 +66,9 @@ makeXMPPGitRemote buddyname jid u = do - git receive-pack <--> xmppReceivePack <---------------> xmpp - - The pipe between git-annex xmppgit and us is set up and communicated - - using two file descriptors, GIT_ANNEX_XMPPGIT_IN and - - GIT_ANNEX_XMPPGIT_OUT. It simply connects those up to its stdin - - and stdout, respectively, which are in turn connected to "git-push". - - There is also a GIT_ANNEX_XMPPGIT_CONTROL descriptor, to which an - - exit status is sent for xmppgit to propigate. + - using two environment variables, relayIn and relayOut, that are set + - to the file descriptors to use. Another, relayControl, is used to + - propigate the exit status of git receive-pack. - - We listen at the other end of the pipe and relay to and from XMPP. -} @@ -97,7 +97,6 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do inh <- liftIO $ fdToHandle readpush outh <- liftIO $ fdToHandle writepush controlh <- liftIO $ fdToHandle writecontrol - liftIO $ hSetBuffering outh NoBuffering t1 <- forkIO <~> toxmpp inh t2 <- forkIO <~> fromxmpp outh controlh @@ -105,13 +104,15 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do {- This can take a long time to run, so avoid running it in the - Annex monad. Also, override environment. -} g <- liftAnnex gitRepo - let g' = g { gitEnv = Just $ M.toList myenv } - let name = Remote.name remote - let params = Param name : map (Param . show) refs - ok <- liftIO $ Git.Command.runBool "push" params g' + let params = Param (Remote.name remote) : map (Param . show) refs + r <- liftIO $ Git.Command.runBool "push" params $ + g { gitEnv = Just $ M.toList myenv } + + liftIO $ do + mapM_ killThread [t1, t2] + mapM_ hClose [inh, outh, controlh] - liftIO $ mapM_ killThread [t1, t2] - return ok + return r where toxmpp inh = forever $ do b <- liftIO $ B.hGetSome inh chunkSize @@ -121,11 +122,9 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do fromxmpp outh controlh = forever $ do m <- waitNetPushMessage case m of - (ReceivePackOutput _ b) -> liftIO $ do - B.hPut outh b - hFlush outh + (ReceivePackOutput _ b) -> liftIO $ writeChunk outh b (ReceivePackDone _ exitcode) -> liftIO $ do - hPutStrLn controlh (show exitcode) + hPrint controlh exitcode hFlush controlh _ -> noop installwrapper tmpdir = liftIO $ do @@ -138,16 +137,21 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do ] modifyFileMode wrapper $ addModes executeModes -relayIn :: String -relayIn = "GIT_ANNEX_XMPPGIT_IN" +type EnvVar = String + +envVar :: String -> EnvVar +envVar s = "GIT_ANNEX_XMPPGIT_" ++ s + +relayIn :: EnvVar +relayIn = envVar "IN" -relayOut :: String -relayOut = "GIT_ANNEX_XMPPGIT_OUT" +relayOut :: EnvVar +relayOut = envVar "OUT" -relayControl :: String -relayControl = "GIT_ANNEX_XMPPGIT_CONTROL" +relayControl :: EnvVar +relayControl = envVar "CONTROL" -relayHandle :: String -> IO Handle +relayHandle :: EnvVar -> IO Handle relayHandle var = do v <- getEnv var case readish =<< v of @@ -160,109 +164,91 @@ relayHandle var = do - we're talking to git-push on stdout - git-receive-pack is talking to us on relayIn (via XMPP) - we're talking to git-receive-pack on relayOut (via XMPP) + - git-receive-pack's exit code will be passed to us on relayControl -} xmppGitRelay :: IO () xmppGitRelay = do - inh <- relayHandle relayIn - outh <- relayHandle relayOut - - hSetBuffering outh NoBuffering - + flip relay stdout =<< relayHandle relayIn + relay stdin =<< relayHandle relayOut + code <- hGetLine =<< relayHandle relayControl + exitWith $ fromMaybe (ExitFailure 1) $ readish code + where {- Is it possible to set up pipes and not need to copy the data - ourselves? See splice(2) -} - void $ forkIO $ forever $ do - b <- B.hGetSome inh chunkSize - when (B.null b) $ do - hClose inh - hClose stdout - killThread =<< myThreadId - B.hPut stdout b - hFlush stdout - void $ forkIO $ forever $ do - b <- B.hGetSome stdin chunkSize + relay fromh toh = void $ forkIO $ forever $ do + b <- B.hGetSome fromh chunkSize when (B.null b) $ do - hClose outh - hClose stdin + hClose fromh + hClose toh killThread =<< myThreadId - B.hPut outh b - hFlush outh - - controlh <- relayHandle relayControl - s <- hGetLine controlh - exitWith $ case readish s of - Just n - | n == 0 -> ExitSuccess - | otherwise -> ExitFailure n - Nothing -> ExitFailure 1 + writeChunk toh b {- 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 (ReceivePushRunning cid) handleDeferred $ do - feeder <- asIO1 toxmpp - reader <- asIO1 fromxmpp - sendexitcode <- asIO1 $ sendNetMessage . ReceivePackDone cid repodir <- liftAnnex $ fromRepo repoPath let p = (proc "git" ["receive-pack", repodir]) { std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit } + (Just inh, Just outh, _, pid) <- liftIO $ createProcess p + readertid <- forkIO <~> relayfromxmpp inh + relaytoxmpp outh + code <- liftIO $ waitForProcess pid + void $ sendNetMessage $ ReceivePackDone cid code liftIO $ do - (Just inh, Just outh, _, pid) <- createProcess p - readertid <- forkIO $ reader inh - void $ feeder outh - code <- waitForProcess pid - void $ sendexitcode code killThread readertid + hClose inh + hClose outh return $ code == ExitSuccess where - toxmpp outh = do + relaytoxmpp outh = do b <- liftIO $ B.hGetSome outh chunkSize - if B.null b - then return () -- EOF - else do - sendNetMessage $ ReceivePackOutput cid b - toxmpp outh - fromxmpp inh = forever $ do + -- empty is EOF, so exit + unless (B.null b) $ do + sendNetMessage $ ReceivePackOutput cid b + relaytoxmpp outh + relayfromxmpp inh = forever $ do m <- waitNetPushMessage case m of - (SendPackOutput _ b) -> liftIO $ do - B.hPut inh b - hFlush inh + (SendPackOutput _ b) -> liftIO $ writeChunk inh b _ -> noop xmppRemotes :: ClientID -> Assistant [Remote] xmppRemotes cid = case baseJID <$> parseJID cid of Nothing -> return [] Just jid -> do - rs <- syncRemotes <$> getDaemonStatus - let want = T.unpack $ formatJID jid - liftAnnex $ filterM (matching want) rs + let loc = gitXMPPLocation jid + filter (matching loc . Remote.repo) . syncRemotes + <$> getDaemonStatus where - matching want remote = do - let r = Remote.repo remote - return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want + matching loc r = repoIsUrl r && repoLocation r == loc -handleDeferred :: NetMessage -> Assistant () -handleDeferred = handlePushMessage +whenXMPPRemote :: ClientID -> Assistant () -> Assistant () +whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid) handlePushMessage :: NetMessage -> Assistant () -handlePushMessage (CanPush cid) = do - rs <- xmppRemotes cid - unless (null rs) $ - sendNetMessage $ PushRequest cid +handlePushMessage (CanPush cid) = whenXMPPRemote cid $ + sendNetMessage $ PushRequest cid handlePushMessage (PushRequest cid) = do rs <- xmppRemotes cid current <- liftAnnex $ inRepo Git.Branch.current --let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO - let refs = [Ref "master:refs/xmpp/newmaster"] + let refs = [Ref "master:refs/remotes/xmpp/newmaster"] forM_ rs $ \r -> xmppPush cid r refs -handlePushMessage (StartingPush cid) = do - rs <- xmppRemotes cid - unless (null rs) $ - void $ xmppReceivePack cid +handlePushMessage (StartingPush cid) = whenXMPPRemote cid $ + void $ xmppReceivePack cid handlePushMessage _ = noop +handleDeferred :: NetMessage -> Assistant () +handleDeferred = handlePushMessage + chunkSize :: Int -chunkSize = 1024 +chunkSize = 4096 + +writeChunk :: Handle -> B.ByteString -> IO () +writeChunk h b = do + B.hPut h b + hFlush h |