git.iko.soy/stackage
on master help sign in
Only create log files when needed
e80a8d0Michael Snoyman
Stackage/PerformBuild.hs+25−11
compare with master
unifiedsplit
@@ -30,7 +30,7 @@ import Stackage.Prelude hiding (pi)
30import System.Directory (findExecutable)
30import System.Directory (findExecutable)
31import System.Environment (getEnvironment)
31import System.Environment (getEnvironment)
32import System.IO (IOMode (WriteMode),
32import System.IO (IOMode (WriteMode),
33− withBinaryFile)
33+ openBinaryFile)
34import System.IO.Temp (withSystemTempDirectory)
34import System.IO.Temp (withSystemTempDirectory)
35
35
36data BuildException = BuildException (Map PackageName BuildFailure) [Text]
36data BuildException = BuildException (Map PackageName BuildFailure) [Text]
@@ -291,11 +291,12 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
291 , display $ ppVersion $ piPlan sbPackageInfo
291 , display $ ppVersion $ piPlan sbPackageInfo
292 ]
292 ]
293
293
294− runIn wdir outH cmd args =
294+ runIn wdir getOutH cmd args = do
295+ outH <- getOutH
295− withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
296+ withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
296 (return () :: IO ())
297 (return () :: IO ())
297 where
298 where
298− cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
299+ cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))
299 { cwd = Just $ fpToString wdir
300 { cwd = Just $ fpToString wdir
300 , std_out = UseHandle outH
301 , std_out = UseHandle outH
301 , std_err = UseHandle outH
302 , std_err = UseHandle outH
@@ -321,8 +322,21 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
321 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
322 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
322
323
323 wf fp inner' = do
324 wf fp inner' = do
325+ ref <- newIORef Nothing
326+ let cleanup = do
327+ mh <- readIORef ref
328+ forM_ mh hClose
329+ getH = do
330+ mh <- readIORef ref
331+ case mh of
332+ Just h -> return h
333+ Nothing -> mask_ $ do
324− createTree $ parent fp
334+ createTree $ parent fp
325− withBinaryFile (fpToString fp) WriteMode inner'
335+ h <- openBinaryFile (fpToString fp) WriteMode
336+ writeIORef ref $ Just h
337+ return h
338+
339+ inner' getH `finally` cleanup
326
340
327 configArgs = ($ []) $ execWriter $ do
341 configArgs = ($ []) $ execWriter $ do
328 when pbAllowNewer $ tell' "--allow-newer"
342 when pbAllowNewer $ tell' "--allow-newer"
@@ -350,15 +364,15 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
350
364
351 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
365 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
352
366
353− buildLibrary = wf libOut $ \outH -> do
367+ buildLibrary = wf libOut $ \getOutH -> do
354 let run a b = do when pbVerbose $ log' (unwords (a : b))
368 let run a b = do when pbVerbose $ log' (unwords (a : b))
355− runChild outH a b
369+ runChild getOutH a b
356
370
357 isUnpacked <- newIORef False
371 isUnpacked <- newIORef False
358 let withUnpacked inner = do
372 let withUnpacked inner = do
359 unlessM (readIORef isUnpacked) $ do
373 unlessM (readIORef isUnpacked) $ do
360 log' $ "Unpacking " ++ namever
374 log' $ "Unpacking " ++ namever
361− runParent outH "cabal" ["unpack", namever]
375+ runParent getOutH "cabal" ["unpack", namever]
362 writeIORef isUnpacked True
376 writeIORef isUnpacked True
363 inner
377 inner
364
378
@@ -440,8 +454,8 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
440
454
441 return withUnpacked
455 return withUnpacked
442
456
443− runTests withUnpacked = wf testOut $ \outH -> do
457+ runTests withUnpacked = wf testOut $ \getOutH -> do
444− let run = runChild outH
458+ let run = runChild getOutH
445
459
446 prevTestResult <- getPreviousResult pb Test pident
460 prevTestResult <- getPreviousResult pb Test pident
447 let needTest = pbEnableTests
461 let needTest = pbEnableTests