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/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/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 134e2249999..567d6aec4e4 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 (hPutStrLn, 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,18 @@ buildAndInstallUnpackedPackage verbosity srcdir builddir = do createDirectoryIfMissingVerbose verbosity True (srcdir builddir) - initLogFile + + 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 @@ -1118,6 +1144,8 @@ buildAndInstallUnpackedPackage verbosity verbosity scriptOptions { useLoggingHandle = mLogFileHandle + , processCloseHandle = False + , processCloseFds = True , useExtraEnvOverrides = dataDirsEnvironmentForPlan distDirLayout plan } (Just (elabPkgDescription pkg)) @@ -1136,11 +1164,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 +1199,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..} buildInplaceUnpackedPackage :: Verbosity + -> LogHandle -> DistDirLayout -> BuildTimeSettings -> Lock -> Lock -> ElaboratedSharedConfig @@ -1174,14 +1209,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 +1237,18 @@ buildInplaceUnpackedPackage verbosity createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams) + 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 @@ -1399,10 +1451,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 +1471,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 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