simpler way to do this

Remove old code that can be trivially implemented using async in a much
nicer way (that is async exception safe).

I've audited all forkOS calls (except for ones in the assistant),
and this was the last remaining one that is not async exception safe.
The rest look ok to me.
This commit is contained in:
Joey Hess 2020-06-05 14:16:37 -04:00
parent 074260f036
commit 660d8d3a87
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 7 additions and 37 deletions

View file

@ -17,7 +17,6 @@ import Assistant.DaemonStatus
import Assistant.ScanRemotes import Assistant.ScanRemotes
import Assistant.RemoteControl import Assistant.RemoteControl
import qualified Command.Sync import qualified Command.Sync
import Utility.Parallel
import qualified Git import qualified Git
import qualified Git.Command import qualified Git.Command
import qualified Remote import qualified Remote
@ -43,6 +42,7 @@ import Database.Export
import Data.Time.Clock import Data.Time.Clock
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async
{- Syncs with remotes that may have been disconnected for a while. {- Syncs with remotes that may have been disconnected for a while.
- -
@ -177,6 +177,11 @@ parallelPush g rs a = do
<*> (Remote.getRepo r >>= \repo -> <*> (Remote.getRepo r >>= \repo ->
sshOptionsTo repo (Remote.gitconfig r) g) sshOptionsTo repo (Remote.gitconfig r) g)
inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
inParallel a l = (\(t,f) -> (map fst t, map fst f))
. partition snd
. zip l <$> mapConcurrently a l
{- Displays an alert while running an action that syncs with some remotes, {- Displays an alert while running an action that syncs with some remotes,
- and returns any remotes that it failed to sync with. - and returns any remotes that it failed to sync with.
- -

View file

@ -1,34 +0,0 @@
{- parallel processing via threads
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
module Utility.Parallel (inParallel) where
import Common
import Control.Concurrent
{- Runs an action in parallel with a set of values, in a set of threads.
- In order for the actions to truely run in parallel, requires GHC's
- threaded runtime,
-
- Returns the values partitioned into ones with which the action succeeded,
- and ones with which it failed. -}
inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
inParallel a l = do
mvars <- mapM thread l
statuses <- mapM takeMVar mvars
return $ reduce $ partition snd $ zip l statuses
where
reduce (x,y) = (map fst x, map fst y)
thread v = do
mvar <- newEmptyMVar
_ <- forkIO $ do
r <- try (a v) :: IO (Either SomeException Bool)
case r of
Left _ -> putMVar mvar False
Right b -> putMVar mvar b
return mvar

View file

@ -298,7 +298,7 @@ custom-setup
filepath, exceptions, bytestring, directory, IfElse, data-default, filepath, exceptions, bytestring, directory, IfElse, data-default,
filepath-bytestring (>= 1.4.2.1.1), filepath-bytestring (>= 1.4.2.1.1),
process (>= 1.6.3), process (>= 1.6.3),
utf8-string, transformers, Cabal async, utf8-string, transformers, Cabal
Executable git-annex Executable git-annex
Main-Is: git-annex.hs Main-Is: git-annex.hs
@ -1085,7 +1085,6 @@ Executable git-annex
Utility.NotificationBroadcaster Utility.NotificationBroadcaster
Utility.OptParse Utility.OptParse
Utility.PID Utility.PID
Utility.Parallel
Utility.PartialPrelude Utility.PartialPrelude
Utility.Path Utility.Path
Utility.Path.Max Utility.Path.Max