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:
parent
074260f036
commit
660d8d3a87
3 changed files with 7 additions and 37 deletions
|
@ -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.
|
||||||
-
|
-
|
||||||
|
|
|
@ -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
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue