fix push status, broken when inParallel was adapted for -threaded

Before pushing ran in its own process, so exitSuccess was the right thing
to do, but with the threaded code, that's caught as an exception.

2 files changed, 8 insertions, 15 deletions

diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 0a0edf1d0..3fe85673b 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -92,33 +92,26 @@ pushToRemotes threadname now st mpushmap remotes = do
 				, show rs
 				]
 			Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
-			{- TODO git push exits nonzero if the remote
-			 - is already up-to-date. This code does not tell
-			 - the difference between the two. Could perhaps
-			 - be check the refs when it seemed to fail?
-			 - Note bewloe  -}
 			(succeeded, failed) <- inParallel (push g branch) rs
+			let ok = null failed
 			case mpushmap of
 				Nothing -> noop
 				Just pushmap -> 
 					changeFailedPushMap pushmap $ \m ->
 						M.union (makemap failed) $
 							M.difference m (makemap succeeded)
-			unless (null failed) $
+			unless (ok) $
 				debug threadname
 					[ "failed to push to"
 					, show failed
 					]
-			if (null failed || not shouldretry)
-				{- TODO see above TODO item -}
-				then return True -- return $ null failed 
+			if (ok || not shouldretry)
+				then return ok
 				else retry branch g failed
 
 		makemap l = M.fromList $ zip l (repeat now)
 
-		push g branch remote =
-			ifM (Command.Sync.pushBranch remote branch g)
-				( exitSuccess, exitFailure)
+		push g branch remote = Command.Sync.pushBranch remote branch g
 
 		retry branch g rs = do
 			debug threadname [ "trying manual pull to resolve failed pushes" ]
diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs
index fcab2a90a..373a0ece5 100644
--- a/Utility/Parallel.hs
+++ b/Utility/Parallel.hs
@@ -18,7 +18,7 @@ import Control.Exception
  -
  - Returns the values partitioned into ones with which the action succeeded,
  - and ones with which it failed. -}
-inParallel :: (v -> IO ()) -> [v] -> IO ([v], [v])
+inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
 inParallel a l = do
 	mvars <- mapM thread l
 	statuses <- mapM takeMVar mvars
@@ -28,8 +28,8 @@ inParallel a l = do
 		thread v = do
 			mvar <- newEmptyMVar
 			_ <- forkIO $ do
-				r <- try (a v) :: IO (Either SomeException ())
+				r <- try (a v) :: IO (Either SomeException Bool)
 				case r of
 					Left _ -> putMVar mvar False
-					Right _ -> putMVar mvar True
+					Right b -> putMVar mvar b
 			return mvar