054fa04 · elk · git.iko.soy

git.iko.soy/elk

use less granular lock when verifying packages

054fa04Evan Czaplicki7 years ago

builder/src/Deps/Solver.hs+27−24

@@ -94,6 +94,7 @@ data Details =

95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))

96verify cache connection registry constraints =

97+ Stuff.withRegistryLock cache $

97 case try constraints of

98 case try constraints of

98 Solver solver ->

99 Solver solver ->

99 solver (State cache connection registry Map.empty)

100 solver (State cache connection registry Map.empty)

@@ -130,6 +131,7 @@ data AppSolution =

130

131

131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)

132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)

132addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

134+ Stuff.withRegistryLock cache $

133 let

135 let

134 allIndirects = Map.union indirect testIndirect

136 allIndirects = Map.union indirect testIndirect

135 allDirects = Map.union direct testDirect

137 allDirects = Map.union direct testDirect

@@ -349,30 +351,31 @@ data Env =

349

351

350initEnv :: IO (Either Exit.RegistryProblem Env)

352initEnv :: IO (Either Exit.RegistryProblem Env)

351initEnv =

353initEnv =

352− Stuff.withRegistryLock $ \cache ->

353− do mvar <- newEmptyMVar

354+ do mvar <- newEmptyMVar

354− _ <- forkIO $ putMVar mvar =<< Http.getManager

355+ _ <- forkIO $ putMVar mvar =<< Http.getManager

356+ cache <- Stuff.getPackageCache

357+ Stuff.withRegistryLock cache $

355− maybeRegistry <- Registry.read cache

358+ do maybeRegistry <- Registry.read cache

356− manager <- readMVar mvar

359+ manager <- readMVar mvar

357−

360+

358− case maybeRegistry of

361+ case maybeRegistry of

359− Nothing ->

362+ Nothing ->

360− do eitherRegistry <- Registry.fetch manager cache

363+ do eitherRegistry <- Registry.fetch manager cache

361− case eitherRegistry of

364+ case eitherRegistry of

362− Right latestRegistry ->

365+ Right latestRegistry ->

363− return $ Right $ Env cache manager (Online manager) latestRegistry

366+ return $ Right $ Env cache manager (Online manager) latestRegistry

364−

367+

365− Left problem ->

368+ Left problem ->

366− return $ Left $ problem

369+ return $ Left $ problem

367−

370+

368− Just cachedRegistry ->

371+ Just cachedRegistry ->

369− do eitherRegistry <- Registry.update manager cache cachedRegistry

372+ do eitherRegistry <- Registry.update manager cache cachedRegistry

370− case eitherRegistry of

373+ case eitherRegistry of

371− Right latestRegistry ->

374+ Right latestRegistry ->

372− return $ Right $ Env cache manager (Online manager) latestRegistry

375+ return $ Right $ Env cache manager (Online manager) latestRegistry

373−

376+

374− Left _ ->

377+ Left _ ->

375− return $ Right $ Env cache manager Offline cachedRegistry

378+ return $ Right $ Env cache manager Offline cachedRegistry

376

379

377

380

378

381

builder/src/Elm/Details.hs+3−3

@@ -291,11 +291,12 @@ fork work =

291

292

293verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details

294−verifyDependencies env@(Env key scope root _ _ _ _) time outline solution directDeps =

294+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =

295 Task.eio id $

296 do Reporting.report key (Reporting.DStart (Map.size solution))

297 mvar <- newEmptyMVar

298+ mvars <- Stuff.withRegistryLock cache $

298− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution

299+ Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution

299 putMVar mvar mvars

300 putMVar mvar mvars

300 deps <- traverse readMVar mvars

301 deps <- traverse readMVar mvars

301 case sequence deps of

302 case sequence deps of

@@ -358,7 +359,6 @@ type Dep =

358

359

359verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep

360verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep

360verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =

361verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =

361− Stuff.withPackageLock cache pkg vsn $

362 do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps

363 exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")

364 if exists

builder/src/Stuff.hs+3−10

@@ -10,7 +10,6 @@ module Stuff

10 , findRoot

11 , withRootLock

12 , withRegistryLock

13− , withPackageLock

14 , PackageCache

13 , PackageCache

15 , getPackageCache

14 , getPackageCache

16 , registry

15 , registry

@@ -128,15 +127,9 @@ withRootLock root work =

128 Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

127 Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

129

128

130

129

131−withRegistryLock :: (PackageCache -> IO a) -> IO a

130+withRegistryLock :: PackageCache -> IO a -> IO a

132−withRegistryLock callback =

131+withRegistryLock (PackageCache dir) work =

133− do cache@(PackageCache dir) <- getPackageCache

134− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> callback cache)

135−

136−

137−withPackageLock :: PackageCache -> Pkg.Name -> V.Version -> IO a -> IO a

138−withPackageLock cache pkg vsn work =

139− Lock.withFileLock (package cache pkg vsn </> "lock") Lock.Exclusive (\_ -> work)

132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

140

133

141

134

142

135