cabal-install: Add log linearization support

This adds support for simultaniously buffering log output in log files and "tail -f"ing the the first package in build order which is still in the process of being built. This results in build output wich is strictly ordered and exactly the same as what -j1 would produce but the actual build is run concurrently and build output shows up on the user's console live, but with only one unit's output being live at any time. That's the tradeoff. You get live output with reproducible order but it doesn't feel qute as "fast" because we're not inteleaving the build output. Initial idea from https://apenwarr.ca/log/20181106.
haskell · Nov 25, 2020 · fde1abb · fde1abb
1 parent b3d0ead
commit fde1abb
Show file tree

Hide file tree

Showing 4 changed files with 277 additions and 13 deletions.
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -159,6 +159,7 @@ executable cabal
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

diff --git a/cabal-install/cabal-install.cabal.zinza b/cabal-install/cabal-install.cabal.zinza
@@ -170,6 +170,7 @@ Version:            3.5.0.0
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -6,6 +6,8 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 
 -- |
 --
@@ -47,6 +49,7 @@ import           Distribution.Client.ProjectConfig
 import           Distribution.Client.ProjectPlanning
 import           Distribution.Client.ProjectPlanning.Types
 import           Distribution.Client.ProjectBuilding.Types
+import           Distribution.Client.ProjectLogging
 import           Distribution.Client.Store
 
 import           Distribution.Client.Types
@@ -98,10 +101,12 @@ import qualified Data.Set as Set
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 
-import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
+import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle, bracket_)
+-- import Control.Exception (Exception (..), Handler (..), SomeAsyncException, SomeException, assert, catches, handle, throwIO, bracket_)
+-- import Data.Function     (on)
 import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
 import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
-import System.IO         (IOMode (AppendMode), withFile)
+import System.IO         (stdout)
 
 import Distribution.Compat.Directory (listDirectory)
 
@@ -569,6 +574,8 @@ rebuildTargets verbosity
     cacheLock     <- newLock -- serialise access to setup exe cache
                              --TODO: [code cleanup] eliminate setup exe cache
 
+    logHandleMap  <- newLogHandleMap pkgsBuildStatus installPlan
+
     debug verbosity $
         "Executing install plan "
      ++ if isParallelBuild
@@ -592,10 +599,14 @@ rebuildTargets verbosity
         handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
 
         let uid = installedUnitId pkg
-            pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in
+            look = Map.findWithDefault (error "rebuildTargets uid not found")
+            pkgBuildStatus = look uid pkgsBuildStatus
+            logHandle = look uid logHandleMap
+        in
 
         rebuildTarget
           verbosity
+          logHandle
           distDirLayout
           storeDirLayout
           buildSettings downloadMap
@@ -635,6 +646,7 @@ createPackageDBIfMissing _ _ _ _ = return ()
 -- | Given all the context and resources, (re)build an individual package.
 --
 rebuildTarget :: Verbosity
+              -> LogHandle
               -> DistDirLayout
               -> StoreDirLayout
               -> BuildTimeSettings
@@ -646,6 +658,7 @@ rebuildTarget :: Verbosity
               -> BuildStatus
               -> IO BuildResult
 rebuildTarget verbosity
+              logHandle
               distDirLayout@DistDirLayout{distBuildDirectory}
               storeDirLayout
               buildSettings downloadMap
@@ -702,7 +715,7 @@ rebuildTarget verbosity
 
     buildAndInstall srcdir builddir =
         buildAndInstallUnpackedPackage
-          verbosity distDirLayout storeDirLayout
+          verbosity logHandle distDirLayout storeDirLayout
           buildSettings registerLock cacheLock
           sharedPackageConfig
           plan rpkg
@@ -714,7 +727,7 @@ rebuildTarget verbosity
     buildInplace buildStatus srcdir builddir =
         --TODO: [nice to have] use a relative build dir rather than absolute
         buildInplaceUnpackedPackage
-          verbosity distDirLayout
+          verbosity logHandle distDirLayout
           buildSettings registerLock cacheLock
           sharedPackageConfig
           plan rpkg
@@ -899,6 +912,7 @@ moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
 
 
 buildAndInstallUnpackedPackage :: Verbosity
+                               -> LogHandle
                                -> DistDirLayout
                                -> StoreDirLayout
                                -> BuildTimeSettings -> Lock -> Lock
@@ -908,6 +922,7 @@ buildAndInstallUnpackedPackage :: Verbosity
                                -> FilePath -> FilePath
                                -> IO BuildResult
 buildAndInstallUnpackedPackage verbosity
+                               logHandle
                                distDirLayout@DistDirLayout{distTempDirectory}
                                storeDirLayout@StoreDirLayout {
                                  storePackageDBStack
@@ -926,7 +941,8 @@ buildAndInstallUnpackedPackage verbosity
                                srcdir builddir = do
 
     createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
-    initLogFile
+
+    bracket_ initLogFile closeLogFile $ do
 
     --TODO: [code cleanup] deal consistently with talking to older
     --      Setup.hs versions, much like we do for ghc, with a proper
@@ -1118,6 +1134,8 @@ buildAndInstallUnpackedPackage verbosity
           verbosity
           scriptOptions
             { useLoggingHandle     = mLogFileHandle
+            , processCloseHandle   = False
+            , processCloseFds      = True
             , useExtraEnvOverrides = dataDirsEnvironmentForPlan
                                      distDirLayout plan }
           (Just (elabPkgDescription pkg))
@@ -1136,11 +1154,17 @@ buildAndInstallUnpackedPackage verbosity
           createDirectoryIfMissing True (takeDirectory logFile)
           exists <- doesFileExist logFile
           when exists $ removeFile logFile
+          openLogHandle logHandle logFile stdout
+
+    closeLogFile =
+      case mlogFile of
+        Nothing -> return ()
+        Just _ -> closeLogHandle logHandle
 
     withLogging action =
       case mlogFile of
-        Nothing      -> action Nothing
-        Just logFile -> withFile logFile AppendMode (action . Just)
+        Nothing -> action Nothing
+        Just _  -> withLogHandle logHandle (action . Just)
 
 
 hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
@@ -1165,6 +1189,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..}
 
 
 buildInplaceUnpackedPackage :: Verbosity
+                            -> LogHandle
                             -> DistDirLayout
                             -> BuildTimeSettings -> Lock -> Lock
                             -> ElaboratedSharedConfig
@@ -1174,14 +1199,19 @@ buildInplaceUnpackedPackage :: Verbosity
                             -> FilePath -> FilePath
                             -> IO BuildResult
 buildInplaceUnpackedPackage verbosity
+                            logHandle
                             distDirLayout@DistDirLayout {
                               distTempDirectory,
                               distPackageCacheDirectory,
                               distDirectory
                             }
-                            BuildTimeSettings{buildSettingNumJobs}
+                            BuildTimeSettings {
+                              buildSettingNumJobs,
+                              buildSettingLogFile
+                            }
                             registerLock cacheLock
                             pkgshared@ElaboratedSharedConfig {
+                              pkgConfigPlatform      = platform,
                               pkgConfigCompiler      = compiler,
                               pkgConfigCompilerProgs = progdb
                             }
@@ -1197,6 +1227,8 @@ buildInplaceUnpackedPackage verbosity
         createDirectoryIfMissingVerbose verbosity True
           (distPackageCacheDirectory dparams)
 
+        bracket_ initLogFile closeLogFile $ do
+
         -- Configure phase
         --
         whenReConfigure $ do
@@ -1399,10 +1431,15 @@ buildInplaceUnpackedPackage verbosity
     setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
           -> IO ()
     setup cmd flags args =
-      setupWrapper verbosity
-                   scriptOptions
-                   (Just (elabPkgDescription pkg))
-                   cmd flags args
+      withLogging $ \mLogFileHandle ->
+        setupWrapper
+          verbosity
+          scriptOptions { useLoggingHandle = mLogFileHandle
+                        , processCloseHandle = False
+                        , processCloseFds    = True
+                        }
+          (Just (elabPkgDescription pkg))
+          cmd flags args
 
     generateInstalledPackageInfo :: IO InstalledPackageInfo
     generateInstalledPackageInfo =
@@ -1414,6 +1451,34 @@ buildInplaceUnpackedPackage verbosity
                                 pkgConfDest
         setup Cabal.registerCommand registerFlags (const [])
 
+    pkgid  = packageId rpkg
+    uid    = installedUnitId rpkg
+
+    mlogFile :: Maybe FilePath
+    mlogFile =
+      case buildSettingLogFile of
+        Nothing        -> Nothing
+        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
+
+    initLogFile =
+      case mlogFile of
+        Nothing      -> return ()
+        Just logFile -> do
+          createDirectoryIfMissing True (takeDirectory logFile)
+          exists <- doesFileExist logFile
+          when exists $ removeFile logFile
+          openLogHandle logHandle logFile stdout
+
+    closeLogFile =
+      case mlogFile of
+        Nothing -> return ()
+        Just _ -> closeLogHandle logHandle
+
+    withLogging action =
+      case mlogFile of
+        Nothing -> action Nothing
+        Just _  -> withLogHandle logHandle (action . Just)
+
 withTempInstalledPackageInfoFile :: Verbosity -> FilePath
                                   -> (FilePath -> IO ())
                                   -> IO InstalledPackageInfo