Skip to content

Commit 001e3cc

Browse files
MikolajMikolaj
authored
Merge pull request #7929 from robx/fix-interrupt
Fix concurrency/exception bugs in asyncFetchPackages
2 parents e5dc4dd + 458bc3a commit 001e3cc

File tree

12 files changed

+341
-90
lines changed

12 files changed

+341
-90
lines changed

‎bootstrap/linux-8.10.7.json

+9
Original file line numberDiff line numberDiff line change
@@ -254,6 +254,15 @@
254254
"source": "hackage",
255255
"version": "0.1.2.0"
256256
},
257+
{
258+
"cabal_sha256": "8bc9cd9991863a238b3531dfc663f262016adbbd814f30b1c63a6ce914ff7906",
259+
"revision": 0,
260+
"src_sha256": "69637f794146a8e7bfbc2db2bd0501c274ec99504b597728e203187790064895",
261+
"flags": [],
262+
"package": "safe-exceptions",
263+
"source": "hackage",
264+
"version": "0.1.7.2"
265+
},
257266
{
258267
"cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0",
259268
"revision": 1,

‎bootstrap/linux-8.6.5.json

+20-11
Original file line numberDiff line numberDiff line change
@@ -254,17 +254,6 @@
254254
"source": "hackage",
255255
"version": "0.1.2.0"
256256
},
257-
{
258-
"cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0",
259-
"revision": 1,
260-
"src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725",
261-
"flags": [
262-
"-bench"
263-
],
264-
"package": "async",
265-
"source": "hackage",
266-
"version": "2.2.4"
267-
},
268257
{
269258
"cabal_sha256": "7ed09aed03683d5b4337088061106c2389d274b3472031a330ff1b220bad2b2d",
270259
"revision": 3,
@@ -276,6 +265,26 @@
276265
"source": "hackage",
277266
"version": "0.10.4"
278267
},
268+
{
269+
"cabal_sha256": "8bc9cd9991863a238b3531dfc663f262016adbbd814f30b1c63a6ce914ff7906",
270+
"revision": 0,
271+
"src_sha256": "69637f794146a8e7bfbc2db2bd0501c274ec99504b597728e203187790064895",
272+
"flags": [],
273+
"package": "safe-exceptions",
274+
"source": "hackage",
275+
"version": "0.1.7.2"
276+
},
277+
{
278+
"cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0",
279+
"revision": 1,
280+
"src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725",
281+
"flags": [
282+
"-bench"
283+
],
284+
"package": "async",
285+
"source": "hackage",
286+
"version": "2.2.4"
287+
},
279288
{
280289
"cabal_sha256": null,
281290
"revision": null,

‎bootstrap/linux-8.8.4.json

+20-11
Original file line numberDiff line numberDiff line change
@@ -254,17 +254,6 @@
254254
"source": "hackage",
255255
"version": "0.1.2.0"
256256
},
257-
{
258-
"cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0",
259-
"revision": 1,
260-
"src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725",
261-
"flags": [
262-
"-bench"
263-
],
264-
"package": "async",
265-
"source": "hackage",
266-
"version": "2.2.4"
267-
},
268257
{
269258
"cabal_sha256": "7ed09aed03683d5b4337088061106c2389d274b3472031a330ff1b220bad2b2d",
270259
"revision": 3,
@@ -276,6 +265,26 @@
276265
"source": "hackage",
277266
"version": "0.10.4"
278267
},
268+
{
269+
"cabal_sha256": "8bc9cd9991863a238b3531dfc663f262016adbbd814f30b1c63a6ce914ff7906",
270+
"revision": 0,
271+
"src_sha256": "69637f794146a8e7bfbc2db2bd0501c274ec99504b597728e203187790064895",
272+
"flags": [],
273+
"package": "safe-exceptions",
274+
"source": "hackage",
275+
"version": "0.1.7.2"
276+
},
277+
{
278+
"cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0",
279+
"revision": 1,
280+
"src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725",
281+
"flags": [
282+
"-bench"
283+
],
284+
"package": "async",
285+
"source": "hackage",
286+
"version": "2.2.4"
287+
},
279288
{
280289
"cabal_sha256": null,
281290
"revision": null,

‎cabal-install/cabal-install.cabal

+11-9
Original file line numberDiff line numberDiff line change
@@ -209,7 +209,7 @@ library
209209
directory >= 1.2.2.0 && < 1.4,
210210
echo >= 0.1.3 && < 0.2,
211211
edit-distance >= 0.2.2 && < 0.3,
212-
exceptions,
212+
exceptions >= 0.10.4 && < 0.11,
213213
filepath >= 1.4.0.0 && < 1.5,
214214
hashable >= 1.0 && < 1.4,
215215
HTTP >= 4000.1.5 && < 4000.4,
@@ -226,7 +226,8 @@ library
226226
text >= 1.2.3 && < 1.3,
227227
parsec >= 3.1.13.0 && < 3.2,
228228
regex-base >= 0.94.0.0 && <0.95,
229-
regex-posix >= 0.96.0.0 && <0.97
229+
regex-posix >= 0.96.0.0 && <0.97,
230+
safe-exceptions >= 0.1.7.0 && < 0.2
230231

231232
if flag(native-dns)
232233
if os(windows)
@@ -275,27 +276,28 @@ Test-Suite unit-tests
275276
UnitTests.Distribution.Client.ArbitraryInstances
276277
UnitTests.Distribution.Client.BuildReport
277278
UnitTests.Distribution.Client.Configure
278-
UnitTests.Distribution.Client.Targets
279+
UnitTests.Distribution.Client.FetchUtils
279280
UnitTests.Distribution.Client.Get
280281
UnitTests.Distribution.Client.Glob
281282
UnitTests.Distribution.Client.GZipUtils
283+
UnitTests.Distribution.Client.IndexUtils
284+
UnitTests.Distribution.Client.IndexUtils.Timestamp
282285
UnitTests.Distribution.Client.Init
283286
UnitTests.Distribution.Client.Init.Golden
284287
UnitTests.Distribution.Client.Init.Interactive
285288
UnitTests.Distribution.Client.Init.NonInteractive
286289
UnitTests.Distribution.Client.Init.Simple
287290
UnitTests.Distribution.Client.Init.Utils
288291
UnitTests.Distribution.Client.Init.FileCreators
292+
UnitTests.Distribution.Client.InstallPlan
293+
UnitTests.Distribution.Client.JobControl
294+
UnitTests.Distribution.Client.ProjectConfig
295+
UnitTests.Distribution.Client.ProjectPlanning
289296
UnitTests.Distribution.Client.Store
290297
UnitTests.Distribution.Client.Tar
298+
UnitTests.Distribution.Client.Targets
291299
UnitTests.Distribution.Client.TreeDiffInstances
292300
UnitTests.Distribution.Client.UserConfig
293-
UnitTests.Distribution.Client.ProjectConfig
294-
UnitTests.Distribution.Client.ProjectPlanning
295-
UnitTests.Distribution.Client.JobControl
296-
UnitTests.Distribution.Client.IndexUtils
297-
UnitTests.Distribution.Client.IndexUtils.Timestamp
298-
UnitTests.Distribution.Client.InstallPlan
299301
UnitTests.Distribution.Solver.Modular.Builder
300302
UnitTests.Distribution.Solver.Modular.RetryLog
301303
UnitTests.Distribution.Solver.Modular.Solver

‎cabal-install/src/Distribution/Client/FetchUtils.hs

+14-7
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ import Distribution.Client.Utils
5252
( ProgressPhase(..), progressMessage )
5353

5454
import qualified Data.Map as Map
55-
import Control.Exception
55+
import qualified Control.Exception.Safe as Safe
5656
import Control.Concurrent.Async
5757
import Control.Concurrent.MVar
5858
import System.Directory
@@ -227,7 +227,10 @@ type AsyncFetchMap = Map UnresolvedPkgLoc
227227
--
228228
-- The body action is passed a map from those packages (identified by their
229229
-- location) to a completion var for that package. So the body action should
230-
-- lookup the location and use 'asyncFetchPackage' to get the result.
230+
-- lookup the location and use 'waitAsyncFetchPackage' to get the result.
231+
--
232+
-- Synchronous exceptions raised by the download actions are delivered
233+
-- via 'waitAsyncFetchPackage'.
231234
--
232235
asyncFetchPackages :: Verbosity
233236
-> RepoContext
@@ -247,13 +250,17 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do
247250
fetchPackages =
248251
for_ asyncDownloadVars $ \(pkgloc, var) -> do
249252
-- Suppress marking here, because 'withAsync' means
250-
-- that we get nondeterministic interleaving
251-
result <- try $ fetchPackage (verboseUnmarkOutput verbosity)
252-
repoCtxt pkgloc
253+
-- that we get nondeterministic interleaving.
254+
-- It is essential that we don't catch async exceptions here,
255+
-- specifically 'AsyncCancelled' thrown at us from 'concurrently'.
256+
result <- Safe.try $
257+
fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc
253258
putMVar var result
254259

255-
withAsync fetchPackages $ \_ ->
256-
body (Map.fromList asyncDownloadVars)
260+
(_, res) <- concurrently
261+
fetchPackages
262+
(body $ Map.fromList asyncDownloadVars)
263+
pure res
257264

258265

259266
-- | Expect to find a download in progress in the given 'AsyncFetchMap'

‎cabal-install/src/Distribution/Client/Types/RepoName.hs

+1-5
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,6 @@
11
{-# LANGUAGE DeriveGeneric #-}
22
module Distribution.Client.Types.RepoName (
33
RepoName (..),
4-
unRepoName,
54
) where
65

76
import Distribution.Client.Compat.Prelude
@@ -17,12 +16,9 @@ import qualified Text.PrettyPrint as Disp
1716
--
1817
-- May be used as path segment.
1918
--
20-
newtype RepoName = RepoName String
19+
newtype RepoName = RepoName { unRepoName :: String }
2120
deriving (Show, Eq, Ord, Generic)
2221

23-
unRepoName :: RepoName -> String
24-
unRepoName (RepoName n) = n
25-
2622
instance Binary RepoName
2723
instance Structured RepoName
2824
instance NFData RepoName

‎cabal-install/src/Distribution/Client/Utils.hs

+4-2
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,9 @@ import Data.List
4949
( groupBy )
5050
import Foreign.C.Types ( CInt(..) )
5151
import qualified Control.Exception as Exception
52-
( finally, bracket )
52+
( finally )
53+
import qualified Control.Exception.Safe as Safe
54+
( bracket )
5355
import System.Directory
5456
( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory
5557
, removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist )
@@ -118,7 +120,7 @@ withTempFileName :: FilePath
118120
-> String
119121
-> (FilePath -> IO a) -> IO a
120122
withTempFileName tmpDir template action =
121-
Exception.bracket
123+
Safe.bracket
122124
(openTempFile tmpDir template)
123125
(\(name, _) -> removeExistingFile name)
124126
(\(name, h) -> hClose h >> action name)

‎cabal-install/tests/UnitTests.hs

+44-40
Original file line numberDiff line numberDiff line change
@@ -3,49 +3,59 @@ module Main (main) where
33

44
import Test.Tasty
55

6-
import qualified UnitTests.Distribution.Solver.Modular.Builder
7-
import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ
8-
import qualified UnitTests.Distribution.Solver.Modular.Solver
9-
import qualified UnitTests.Distribution.Solver.Modular.RetryLog
10-
import qualified UnitTests.Distribution.Solver.Types.OptionalStanza
116
import qualified UnitTests.Distribution.Client.BuildReport
127
import qualified UnitTests.Distribution.Client.Configure
8+
import qualified UnitTests.Distribution.Client.FetchUtils
9+
import qualified UnitTests.Distribution.Client.Get
1310
import qualified UnitTests.Distribution.Client.Glob
1411
import qualified UnitTests.Distribution.Client.GZipUtils
15-
import qualified UnitTests.Distribution.Client.Store
16-
import qualified UnitTests.Distribution.Client.Tar
17-
import qualified UnitTests.Distribution.Client.Targets
18-
import qualified UnitTests.Distribution.Client.UserConfig
19-
import qualified UnitTests.Distribution.Client.ProjectConfig
20-
import qualified UnitTests.Distribution.Client.ProjectPlanning
21-
import qualified UnitTests.Distribution.Client.JobControl
2212
import qualified UnitTests.Distribution.Client.IndexUtils
2313
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
2414
import qualified UnitTests.Distribution.Client.Init
2515
import qualified UnitTests.Distribution.Client.InstallPlan
26-
import qualified UnitTests.Distribution.Client.Get
16+
import qualified UnitTests.Distribution.Client.JobControl
17+
import qualified UnitTests.Distribution.Client.ProjectConfig
18+
import qualified UnitTests.Distribution.Client.ProjectPlanning
19+
import qualified UnitTests.Distribution.Client.Store
20+
import qualified UnitTests.Distribution.Client.Tar
21+
import qualified UnitTests.Distribution.Client.Targets
22+
import qualified UnitTests.Distribution.Client.UserConfig
23+
import qualified UnitTests.Distribution.Solver.Modular.Builder
24+
import qualified UnitTests.Distribution.Solver.Modular.RetryLog
25+
import qualified UnitTests.Distribution.Solver.Modular.Solver
26+
import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ
27+
import qualified UnitTests.Distribution.Solver.Types.OptionalStanza
2728

2829
main :: IO ()
2930
main = do
3031
initTests <- UnitTests.Distribution.Client.Init.tests
3132
defaultMain $ testGroup "Unit Tests"
32-
[ testGroup "UnitTests.Distribution.Solver.Modular.Builder"
33-
UnitTests.Distribution.Solver.Modular.Builder.tests
34-
, testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"
35-
UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests
36-
, testGroup "UnitTests.Distribution.Solver.Modular.Solver"
37-
UnitTests.Distribution.Solver.Modular.Solver.tests
38-
, testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"
39-
UnitTests.Distribution.Solver.Modular.RetryLog.tests
40-
, UnitTests.Distribution.Solver.Types.OptionalStanza.tests
41-
, testGroup "UnitTests.Distribution.Client.Glob"
42-
UnitTests.Distribution.Client.Glob.tests
33+
[ testGroup "UnitTests.Distribution.Client.BuildReport"
34+
UnitTests.Distribution.Client.BuildReport.tests
4335
, testGroup "UnitTests.Distribution.Client.Configure"
4436
UnitTests.Distribution.Client.Configure.tests
37+
, testGroup "UnitTests.Distribution.Client.FetchUtils"
38+
UnitTests.Distribution.Client.FetchUtils.tests
39+
, testGroup "UnitTests.Distribution.Client.Get"
40+
UnitTests.Distribution.Client.Get.tests
41+
, testGroup "UnitTests.Distribution.Client.Glob"
42+
UnitTests.Distribution.Client.Glob.tests
4543
, testGroup "Distribution.Client.GZipUtils"
4644
UnitTests.Distribution.Client.GZipUtils.tests
45+
, testGroup "UnitTests.Distribution.Client.IndexUtils"
46+
UnitTests.Distribution.Client.IndexUtils.tests
47+
, testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"
48+
UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
4749
, testGroup "Distribution.Client.Init"
4850
initTests
51+
, testGroup "UnitTests.Distribution.Client.InstallPlan"
52+
UnitTests.Distribution.Client.InstallPlan.tests
53+
, testGroup "UnitTests.Distribution.Client.JobControl"
54+
UnitTests.Distribution.Client.JobControl.tests
55+
, testGroup "UnitTests.Distribution.Client.ProjectConfig"
56+
UnitTests.Distribution.Client.ProjectConfig.tests
57+
, testGroup "UnitTests.Distribution.Client.ProjectPlanning"
58+
UnitTests.Distribution.Client.ProjectPlanning.tests
4959
, testGroup "Distribution.Client.Store"
5060
UnitTests.Distribution.Client.Store.tests
5161
, testGroup "Distribution.Client.Tar"
@@ -54,20 +64,14 @@ main = do
5464
UnitTests.Distribution.Client.Targets.tests
5565
, testGroup "UnitTests.Distribution.Client.UserConfig"
5666
UnitTests.Distribution.Client.UserConfig.tests
57-
, testGroup "UnitTests.Distribution.Client.ProjectConfig"
58-
UnitTests.Distribution.Client.ProjectConfig.tests
59-
, testGroup "UnitTests.Distribution.Client.ProjectPlanning"
60-
UnitTests.Distribution.Client.ProjectPlanning.tests
61-
, testGroup "UnitTests.Distribution.Client.JobControl"
62-
UnitTests.Distribution.Client.JobControl.tests
63-
, testGroup "UnitTests.Distribution.Client.IndexUtils"
64-
UnitTests.Distribution.Client.IndexUtils.tests
65-
, testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"
66-
UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
67-
, testGroup "UnitTests.Distribution.Client.InstallPlan"
68-
UnitTests.Distribution.Client.InstallPlan.tests
69-
, testGroup "UnitTests.Distribution.Client.Get"
70-
UnitTests.Distribution.Client.Get.tests
71-
, UnitTests.Distribution.Client.BuildReport.tests
72-
67+
, testGroup "UnitTests.Distribution.Solver.Modular.Builder"
68+
UnitTests.Distribution.Solver.Modular.Builder.tests
69+
, testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"
70+
UnitTests.Distribution.Solver.Modular.RetryLog.tests
71+
, testGroup "UnitTests.Distribution.Solver.Modular.Solver"
72+
UnitTests.Distribution.Solver.Modular.Solver.tests
73+
, testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"
74+
UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests
75+
, testGroup "UnitTests.Distribution.Solver.Types.OptionalStanza"
76+
UnitTests.Distribution.Solver.Types.OptionalStanza.tests
7377
]

‎cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import UnitTests.Distribution.Client.TreeDiffInstances ()
99

1010
import Data.TreeDiff.QuickCheck (ediffEq)
1111
import Test.QuickCheck (Property, counterexample)
12-
import Test.Tasty (TestTree, testGroup)
12+
import Test.Tasty (TestTree)
1313
import Test.Tasty.QuickCheck (testProperty)
1414

1515
import Distribution.Client.BuildReports.Anonymous (BuildReport, parseBuildReport, showBuildReport)
@@ -18,8 +18,8 @@ import Distribution.Simple.Utils (toUTF8BS)
1818
-- instances
1919
import Test.QuickCheck.Instances.Cabal ()
2020

21-
tests :: TestTree
22-
tests = testGroup "BuildReport"
21+
tests :: [TestTree]
22+
tests =
2323
[ testProperty "test" roundtrip
2424
]
2525

0 commit comments

Comments
 (0)