use System.Timeout

I'd forgotten this existed!

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

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