From b3d0ead779ef85006357e35b74fc3133eb1060a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 26 Jul 2019 07:44:49 +0200 Subject: [PATCH 1/3] SetupWrapper: Allow controlling FDs leaks in child procsesses The way we currently call createProcess makes all open file descriptors leak into child processes. This is not only a cosmetic problem but also lead to really nasty concurrency bugs. This doesn't seem to really be a problem currently but I'm about to commit some code that breaks with leaking handles. Unfortunately we cannot simply use 'close_fds' always as, according to the docs, it doesn't work on windows when the std streams are not inherited from the parent process. I also introduce a separate field which allows making the handles we pass to the child process "leak" in the parent. By default 'createProcess' closes handles passed to the child process but in my case the handles are a pipe/pty-slave that I cannot easily re-open. --- .../src/Distribution/Client/Configure.hs | 2 ++ .../Distribution/Client/ProjectPlanning.hs | 4 ++- .../src/Distribution/Client/SetupWrapper.hs | 34 ++++++++++++++----- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 101fc604118..ebb852fdd55 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -218,6 +218,8 @@ configureSetupScript packageDBs , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps , isInteractive = False + , processCloseHandle = True + , processCloseFds = False } where -- When we are compiling a legacy setup script without an explicit diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 29dd1937ae8..b5696ebc6a0 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -3209,7 +3209,9 @@ setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) useWin32CleanHack = False, --TODO: [required eventually] forceExternalSetupMethod = isParallelBuild, setupCacheLock = Just cacheLock, - isInteractive = False + isInteractive = False, + processCloseHandle = True, + processCloseFds = False } diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 22ccf021128..c25600c6cc6 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -110,7 +110,8 @@ import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) import Distribution.Compat.Process (createProcess) -import System.Process ( StdStream(..), proc, waitForProcess +import System.Process ( createProcess_ + , StdStream(..), proc, waitForProcess , ProcessHandle ) import qualified System.Process as Process import Data.List ( foldl1' ) @@ -250,7 +251,17 @@ data SetupScriptOptions = SetupScriptOptions { -- | Is the task we are going to run an interactive foreground task, -- or an non-interactive background task? Based on this flag we -- decide whether or not to delegate ctrl+c to the spawned task - isInteractive :: Bool + isInteractive :: Bool, + + + -- | When running Setup in an external process, should we close the log + -- handle ('useLoggingHandle') in the parent process after spawning the + -- child? + processCloseHandle :: Bool, + + -- | When running Setup in an external process, should we close all + -- non-standard file descriptors before executing the child process? + processCloseFds :: Bool } defaultSetupScriptOptions :: SetupScriptOptions @@ -273,7 +284,9 @@ defaultSetupScriptOptions = SetupScriptOptions { useWin32CleanHack = False, forceExternalSetupMethod = False, setupCacheLock = Nothing, - isInteractive = False + isInteractive = False, + processCloseHandle = True, + processCloseFds = False } workingDir :: SetupScriptOptions -> FilePath @@ -449,16 +462,19 @@ runProcess' :: FilePath -- ^ Filename of the executable -> Maybe Handle -- ^ Handle for @stdout@ -> Maybe Handle -- ^ Handle for @stderr@ -> Bool -- ^ Delegate Ctrl+C ? + -> Bool -- ^ Close handles ? + -> Bool -- ^ Close nonstandard fds before exec ? -> IO ProcessHandle -runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do +runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr delegate close_handles close_fds = do (_,_,_,ph) <- - createProcess + (if close_handles then createProcess else createProcess_ "runProcess'") (proc cmd args){ Process.cwd = mb_cwd , Process.env = mb_env , Process.std_in = mbToStd mb_stdin , Process.std_out = mbToStd mb_stdout , Process.std_err = mbToStd mb_stderr - , Process.delegate_ctlc = _delegate + , Process.delegate_ctlc = delegate + , Process.close_fds = close_fds } return ph where @@ -494,7 +510,8 @@ selfExecSetupMethod verbosity options bt args0 = do process <- runProcess' path args (useWorkingDir options) env Nothing (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) + (isInteractive options) (processCloseHandle options) + (processCloseFds options) exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode @@ -531,7 +548,8 @@ externalSetupMethod path verbosity options _ args = do process <- runProcess' path' args (useWorkingDir options) env Nothing (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) + (isInteractive options) (processCloseHandle options) + (processCloseFds options) exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode From 55c88058c8e8b44b56a5241d8b3921e6be60a17e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 17 Aug 2019 15:52:05 +0200 Subject: [PATCH 2/3] 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. --- cabal-install/cabal-install.cabal | 1 + cabal-install/cabal-install.cabal.dev | 1 + cabal-install/cabal-install.cabal.prod | 1 + cabal-install/cabal-install.cabal.zinza | 1 + .../Distribution/Client/ProjectBuilding.hs | 91 ++++++-- .../src/Distribution/Client/ProjectLogging.hs | 197 ++++++++++++++++++ 6 files changed, 279 insertions(+), 13 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/ProjectLogging.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 70e936ffb0e..b8d0ffe2965 100644 --- 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.dev b/cabal-install/cabal-install.cabal.dev index 5c51b28f9ea..469265dacc1 100644 --- a/cabal-install/cabal-install.cabal.dev +++ b/cabal-install/cabal-install.cabal.dev @@ -151,6 +151,7 @@ library cabal-lib-client 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.prod b/cabal-install/cabal-install.cabal.prod index 70e936ffb0e..b8d0ffe2965 100644 --- a/cabal-install/cabal-install.cabal.prod +++ b/cabal-install/cabal-install.cabal.prod @@ -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 index eee195a8a85..a8dbf9d69d7 100644 --- 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 index 134e2249999..734b8eb8b2c 100644 --- 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 diff --git a/cabal-install/src/Distribution/Client/ProjectLogging.hs b/cabal-install/src/Distribution/Client/ProjectLogging.hs new file mode 100644 index 00000000000..3a4704e003f --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectLogging.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NondecreasingIndentation #-} + +-- | Support for linearized logging +-- +module Distribution.Client.ProjectLogging + ( LogHandle -- abstract + , newLogHandleMap + , openLogHandle + , withLogHandle + , getLogHandle + , closeLogHandle + ) where + +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectBuilding.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.Types (GenericReadyPackage(..)) +import Distribution.Package +import Distribution.Utils.Generic (ordNub) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad +import Control.Exception (try, throwIO, assert) +import Control.Concurrent +import Control.Concurrent.Async +import System.IO +import System.IO.Error +import System.Posix.IO hiding (createPipe) +import System.Posix.Terminal +import GHC.IO.Exception + +data LogHandleState + = Buffering + | Forwarding + | Closed + deriving (Eq, Ord, Read, Show) + +data LogHandleVar = LogHandleVar + { lhState :: LogHandleState + , lhTTY :: Handle + , lhFile :: Handle + , lhMaster :: Handle + , lhSlave :: Handle + , lhFilePath :: FilePath + , lhAsync :: Async () + } deriving (Eq) + +data LogHandle = LogHandle + { _lhUnitId :: UnitId + , lhNext :: Maybe LogHandle + , lhFirst :: Bool + , lhVar :: MVar LogHandleVar + } deriving (Eq) + +type LogHandleMap = Map UnitId LogHandle +newLogHandleMap :: BuildStatusMap -> ElaboratedInstallPlan -> IO LogHandleMap +newLogHandleMap pkgsBuildStatus installPlan = fmap Map.fromList $ do + foldM newLogHandle [] (reverse (uids `zip` (True : repeat False))) + where + newLogHandle lhds (uid, first) = do + mv <- newEmptyMVar + return $ (uid, LogHandle uid (snd <$> headMay lhds) first mv) : lhds + + headMay [] = Nothing + headMay (x:_) = Just x + + -- All the units that need building. If we get this wrong we'll hang + -- forever in passForwarding as the next LogHandle will never be opened + -- so watch out. + uids = assert (ordNub uids' == uids') uids' + uids' = + [ uid + | ReadyPackage elab + <- InstallPlan.executionOrder installPlan + , let uid = installedUnitId elab + pkgBuildStatus = Map.findWithDefault (error "newLogHandleMap uid not found") uid pkgsBuildStatus + , buildStatusRequiresBuild pkgBuildStatus + ] + +openLogHandle :: LogHandle -> FilePath -> Handle -> IO () +openLogHandle lh@LogHandle{lhVar=mv, lhFirst} logFile ttyhdl = do + mlhv <- tryTakeMVar mv + putMVar mv =<< case fmap lhState mlhv of + Nothing -> do + filehdl <- openFile logFile ReadWriteMode + (amux, master, slave) <- newLogMuxThread lh + return $ LogHandleVar + { lhState = if lhFirst then Forwarding else Buffering + , lhTTY = ttyhdl + , lhFile = filehdl + , lhMaster = master + , lhSlave = slave + , lhFilePath = logFile + , lhAsync = amux + } + Just Buffering -> do + error "openLogFile: already buffering!" + Just Forwarding -> + error "openLogFile: already forwarding!" + Just Closed -> + error "openLogFile: already closed!" + +withLogHandle :: LogHandle -> (Handle -> IO a) -> IO a +withLogHandle lh action = action =<< getLogHandle lh + +getLogHandle :: LogHandle -> IO Handle +getLogHandle LogHandle{lhVar=mv} = do + lhv <- readMVar mv + when (lhState lhv == Closed) $ + error "withLogHandle: already closed!" + return (lhSlave lhv) + +closeLogHandle :: LogHandle -> IO () +closeLogHandle lh@LogHandle{lhVar=mv} = do + amux <- withMVar mv $ \lhv -> do + when (lhState lhv == Closed) $ + error "closeLogHandle: already closed!" + hClose $ lhSlave lhv -- signal mux thread to exit + return $ lhAsync lhv + wait amux + + -- now we can close the rest without breaking the mux thread + modifyMVar_ mv $ \lhv -> do + hClose $ lhFile lhv + when (lhState lhv == Forwarding) $ + void $ forkIO $ passForwarding lh + return lhv { lhState = Closed } + + where + drain whdl rhdl = do + ebuf <- BS.hGetSome rhdl 4096 + case ebuf of + buf | BS.null buf -> return () + buf -> do + BS.hPut whdl buf + drain whdl rhdl + + passForwarding LogHandle{lhNext=Nothing} = + return () + passForwarding LogHandle{lhNext=Just nlh} = do + let nmv = lhVar nlh + modifyMVar_ nmv $ \nlhv -> do -- waits until openend + case lhState nlhv of + Forwarding -> + error $ "passForwarding: next handle already forwarding!?" + Closed -> do + LBS.hPut (lhTTY nlhv) =<< LBS.readFile (lhFilePath nlhv) + passForwarding nlh + return nlhv + Buffering -> do + hSeek (lhFile nlhv) AbsoluteSeek 0 + drain (lhTTY nlhv) (lhFile nlhv) + hSeek (lhFile nlhv) SeekFromEnd 0 + return $ nlhv { lhState = Forwarding } + +newLogMuxThread :: LogHandle -> IO (Async (), Handle, Handle) +newLogMuxThread LogHandle{lhVar=mv} = do +-- (rhdl, whdl) <- createPipe -- pipes are nice and portable but buffer +-- the output like crazy. There really is no way around ptys for smooth +-- output -- at least that I can find. + (master, slave) <- openPseudoTerminal + rhdl <- fdToHandle master + whdl <- fdToHandle slave + amux <- async $ loop rhdl + return (amux, rhdl, whdl) + where + loop rhdl = do + ebuf <- try $ BS.hGetSome rhdl 512 + case ebuf of + -- pty master will throw EIO on slave close (at least on linux) + Left err | ioeGetErrorType err == HardwareFault -> do + hClose rhdl + + -- BS.hGetSome will usually signal EOF of a pipe via zero buffer + -- size. For pty masters this doesn't happen, see below. "Some + -- platforms" might still do it this way (ugh). + Right buf | BS.null buf -> do + hClose rhdl + + Left err -> throwIO err + Right buf -> do + LogHandleVar{lhState, lhTTY, lhFile} <- readMVar mv + case lhState of + Forwarding -> do + BS.hPut lhTTY buf + BS.hPut lhFile buf + Buffering -> + BS.hPut lhFile buf + Closed -> + error "newLogMuxThread.loop: handle closed prematurely" + loop rhdl From 4873adcf933558a77cd1cc7b4e6ae5b1456e53f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 17 Aug 2019 16:04:38 +0200 Subject: [PATCH 3/3] Add entering/leaving directory messages to build output Ok, so here's the deal: with v2-build we can have multiple different package directories in one build. At the moment we always start GHC in the package directory with the paths to the sources being relative to that. GHC's error messages are going to copy those paths verbatim. Now when we have multiple packages in seperate directories, say: proj/ pkg-a/A.hs pkg-b/B.hs then error messages are juts going to mention "A.hs" or "B.hs" without the pkg-* prefix. So while this is kinda confusing for users that's not really the main problem. Editors (Emacs in my case) usually have a mode that parses compiler output to provide jump-to-error functionality. This usually relies on the paths in error messages being relative to the current directory of the editor or some such but we break this assumption with v2-build. It turns out we're not the first build-tool to have this problem, recursive make pretty much has the same problem and the "solution" there is to just print messages before and after starting a recursive instance of the build system in another directory. Editors already have support to parse these annotations so I'm just adding support to do that to cabal. Cabal's equivalent of the recursive make instance is Setup.hs/SetupWrapper which for v2 is always invoked through either 'buildInplaceUnpackedPackage' or 'buildAndInstallUnpackedPackage' so we add code there to print these messages. Together with the preceeding commit adding log linearizaton we can actually guarantee that the output will make sense to editors trying to parse it since it's as if we'd run with -j1, unlike the mess 'make' makes of things when concurrent builds are active! --- .../Distribution/Client/ProjectBuilding.hs | 22 ++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 734b8eb8b2c..567d6aec4e4 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -106,7 +106,7 @@ import Control.Exception (Handler (..), SomeAsyncException, assert, catches, han -- import Data.Function (on) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) -import System.IO (stdout) +import System.IO (hPutStrLn, stdout) import Distribution.Compat.Directory (listDirectory) @@ -944,6 +944,16 @@ buildAndInstallUnpackedPackage verbosity bracket_ initLogFile closeLogFile $ do + let + entering = withLogging $ \mLogFileHandle -> do + let hdl = fromMaybe stdout mLogFileHandle + hPutStrLn hdl $ "Entering directory '" ++ srcdir ++ "'" + leaving = withLogging $ \mLogFileHandle -> do + let hdl = fromMaybe stdout mLogFileHandle + hPutStrLn hdl $ "Leaving directory '" ++ srcdir ++ "'" + + bracket_ entering leaving $ do + --TODO: [code cleanup] deal consistently with talking to older -- Setup.hs versions, much like we do for ghc, with a proper -- options type and rendering step which will also let us @@ -1229,6 +1239,16 @@ buildInplaceUnpackedPackage verbosity bracket_ initLogFile closeLogFile $ do + let + entering = withLogging $ \mLogFileHandle -> do + let hdl = fromMaybe stdout mLogFileHandle + hPutStrLn hdl $ "Entering directory '" ++ srcdir ++ "'" + leaving = withLogging $ \mLogFileHandle -> do + let hdl = fromMaybe stdout mLogFileHandle + hPutStrLn hdl $ "Leaving directory '" ++ srcdir ++ "'" + + bracket_ entering leaving $ do + -- Configure phase -- whenReConfigure $ do