diff options
| -rw-r--r-- | Assistant/XMPP/Git.hs | 24 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 14 |
2 files changed, 12 insertions, 26 deletions
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index da143eae4..d3c8343c2 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -25,7 +25,6 @@ import qualified Git.Branch import Locations.UserConfig import qualified Types.Remote as Remote import Utility.FileMode -import Utility.ThreadScheduler import Network.Protocol.XMPP import qualified Data.Text as T @@ -33,6 +32,7 @@ import System.Posix.Env import System.Posix.Types import System.Process (std_in, std_out, std_err) import Control.Concurrent +import System.Timeout import qualified Data.ByteString as B import qualified Data.Map as M @@ -119,16 +119,16 @@ xmppPush cid gitpush = runPush SendPack cid handleDeferred $ do then liftIO $ killThread =<< myThreadId else sendNetMessage $ Pushing cid $ SendPackOutput b fromxmpp outh controlh = forever $ do - m <- runTimeout xmppTimeout <~> waitNetPushMessage SendPack + m <- timeout xmppTimeout <~> waitNetPushMessage SendPack case m of - (Right (Pushing _ (ReceivePackOutput b))) -> + (Just (Pushing _ (ReceivePackOutput b))) -> liftIO $ writeChunk outh b - (Right (Pushing _ (ReceivePackDone exitcode))) -> + (Just (Pushing _ (ReceivePackDone exitcode))) -> liftIO $ do hPrint controlh exitcode hFlush controlh - (Right _) -> noop - (Left _) -> do + (Just _) -> noop + Nothing -> do debug ["timeout waiting for git receive-pack output via XMPP"] -- Send a synthetic exit code to git-annex -- xmppgit, which will exit and cause git push @@ -220,12 +220,12 @@ xmppReceivePack cid = runPush ReceivePack cid handleDeferred $ do sendNetMessage $ Pushing cid $ ReceivePackOutput b relaytoxmpp outh relayfromxmpp inh = forever $ do - m <- runTimeout xmppTimeout <~> waitNetPushMessage ReceivePack + m <- timeout xmppTimeout <~> waitNetPushMessage ReceivePack case m of - (Right (Pushing _ (SendPackOutput b))) -> + (Just (Pushing _ (SendPackOutput b))) -> liftIO $ writeChunk inh b - (Right _) -> noop - (Left _) -> do + (Just _) -> noop + Nothing -> do debug ["timeout waiting for git send-pack output via XMPP"] -- closing the handle will make -- git receive-pack exit @@ -291,5 +291,5 @@ chunkSize = 4096 - delayed for running until the timeout is reached, so it should not be - excessive. -} -xmppTimeout :: Seconds -xmppTimeout = Seconds 120 +xmppTimeout :: Int +xmppTimeout = 120000000 -- 120 seconds diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index 5e165c9ca..c95225598 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -12,7 +12,6 @@ import Common import Control.Concurrent import Control.Exception -import Control.Concurrent.Async import System.Posix.Terminal import System.Posix.Signals @@ -46,19 +45,6 @@ unboundDelay time = do threadDelay $ fromInteger maxWait when (maxWait /= time) $ unboundDelay (time - maxWait) -{- Runs an action until a timeout is reached. If it fails to complete in - - time, or throws an exception, returns a Left value. - - - - Note that if the action runs an unsafe foreign call, the signal to - - cancel it may not arrive until the call returns. -} -runTimeout :: Seconds -> IO a -> IO (Either SomeException a) -runTimeout secs a = do - runner <- async a - controller <- async $ do - threadDelaySeconds secs - cancel runner - cancel controller `after` waitCatch runner - {- Pauses the main thread, letting children run until program termination. -} waitForTermination :: IO () waitForTermination = do |