diff options
Diffstat (limited to 'Assistant/XMPP')
| -rw-r--r-- | Assistant/XMPP/Git.hs | 93 |
1 files changed, 59 insertions, 34 deletions
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 49adadcfd..904076134 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -19,7 +19,7 @@ import Assistant.Sync import Annex.UUID import Config import Git -import Git.Command +import qualified Git.Command import qualified Git.Branch import qualified Annex.Branch import Locations.UserConfig @@ -33,6 +33,7 @@ import System.Posix.Types import System.Process (std_in, std_out, std_err) import Control.Concurrent import qualified Data.ByteString as B +import qualified Data.Map as M finishXMPPPairing :: JID -> UUID -> Assistant () finishXMPPPairing jid u = void $ alertWhile alert $ @@ -85,15 +86,13 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do env <- liftIO getEnvironment path <- liftIO getSearchPath - let myenv = + let myenv = M.fromList [ ("PATH", join [searchPathSeparator] $ tmpdir:path) , (relayIn, show inf) , (relayOut, show outf) , (relayControl, show controlf) ] - g <- liftAnnex gitRepo - let name = Remote.name remote - let params = Param "push" : Param name : map (Param . show) refs + `M.union` M.fromList env inh <- liftIO $ fdToHandle readpush outh <- liftIO $ fdToHandle writepush @@ -103,23 +102,31 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do t1 <- forkIO <~> toxmpp inh t2 <- forkIO <~> fromxmpp outh controlh - ok <- liftIO $ boolSystemEnv "git" - (gitCommandLine params g) - (Just $ env ++ myenv) + {- 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' + liftIO $ mapM_ killThread [t1, t2] return ok where toxmpp inh = forever $ do - b <- liftIO $ B.hGetSome inh 1024 + b <- liftIO $ B.hGetSome inh chunkSize if B.null b then liftIO $ killThread =<< myThreadId else sendNetMessage $ SendPackOutput cid b fromxmpp outh controlh = forever $ do m <- waitNetPushMessage case m of - (ReceivePackOutput _ b) -> liftIO $ B.hPut outh b - (ReceivePackDone _ exitcode) -> do - liftIO $ hPutStrLn controlh (show exitcode) + (ReceivePackOutput _ b) -> liftIO $ do + B.hPut outh b + hFlush outh + (ReceivePackDone _ exitcode) -> liftIO $ do + hPutStrLn controlh (show exitcode) + hFlush controlh _ -> noop installwrapper tmpdir = liftIO $ do createDirectoryIfMissing True tmpdir @@ -147,7 +154,13 @@ relayHandle var = do Nothing -> error $ var ++ " not set" Just n -> fdToHandle $ Fd n -{- Called by git-annex xmppgit. -} +{- Called by git-annex xmppgit. + - + - git-push is talking to us on stdin + - 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) + -} xmppGitRelay :: IO () xmppGitRelay = do inh <- relayHandle relayIn @@ -158,11 +171,21 @@ xmppGitRelay = do {- 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 1024 - when (B.null b) $ + b <- B.hGetSome inh chunkSize + when (B.null b) $ do + hClose inh + hClose stdout killThread =<< myThreadId B.hPut stdout b - void $ forkIO $ forever $ B.hGetSome stdin 1024 >>= B.hPut outh + hFlush stdout + void $ forkIO $ forever $ do + b <- B.hGetSome stdin chunkSize + when (B.null b) $ do + hClose outh + hClose stdin + killThread =<< myThreadId + B.hPut outh b + hFlush outh controlh <- relayHandle relayControl s <- hGetLine controlh @@ -187,15 +210,15 @@ xmppReceivePack cid = runPush (ReceivePushRunning cid) handleDeferred $ do } liftIO $ do (Just inh, Just outh, _, pid) <- createProcess p - feedertid <- forkIO $ feeder outh - void $ reader inh + readertid <- forkIO $ reader inh + void $ feeder outh code <- waitForProcess pid void $ sendexitcode code - killThread feedertid + killThread readertid return $ code == ExitSuccess where toxmpp outh = do - b <- liftIO $ B.hGetSome outh 1024 + b <- liftIO $ B.hGetSome outh chunkSize if B.null b then return () -- EOF else do @@ -204,7 +227,9 @@ xmppReceivePack cid = runPush (ReceivePushRunning cid) handleDeferred $ do fromxmpp inh = forever $ do m <- waitNetPushMessage case m of - (SendPackOutput _ b) -> liftIO $ B.hPut inh b + (SendPackOutput _ b) -> liftIO $ do + B.hPut inh b + hFlush inh _ -> noop xmppRemotes :: ClientID -> Assistant [Remote] @@ -220,24 +245,24 @@ xmppRemotes cid = case baseJID <$> parseJID cid of return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want handleDeferred :: NetMessage -> Assistant () -handleDeferred = void . handlePushMessage +handleDeferred = handlePushMessage -handlePushMessage :: NetMessage -> Assistant Bool +handlePushMessage :: NetMessage -> Assistant () handlePushMessage (CanPush cid) = do rs <- xmppRemotes cid - if null rs - then return False - else do - sendNetMessage $ PushRequest cid - return True + unless (null rs) $ + sendNetMessage $ PushRequest cid handlePushMessage (PushRequest cid) = do rs <- xmppRemotes cid current <- liftAnnex $ inRepo Git.Branch.current - let refs = catMaybes [current, Just Annex.Branch.fullname] - any id <$> (forM rs $ \r -> xmppPush cid r refs) + --let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO + let refs = [Ref "master:refs/xmpp/newmaster"] + forM_ rs $ \r -> xmppPush cid r refs handlePushMessage (StartingPush cid) = do rs <- xmppRemotes cid - if null rs - then return False - else xmppReceivePack cid -handlePushMessage _ = return False + unless (null rs) $ + void $ xmppReceivePack cid +handlePushMessage _ = noop + +chunkSize :: Int +chunkSize = 1024 |