From c4294b53358751991c991905b3f6a8ebd72dcc55 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 2 Aug 2024 22:41:07 +0100 Subject: [PATCH] Add progName, mExecutablePath to GlobalOpts --- doc/maintainers/stack_errors.md | 3 ++- src/Stack.hs | 3 ++- src/Stack/Build/Execute.hs | 14 +++++++++----- src/Stack/Docker.hs | 22 ++++++++++++++------- src/Stack/Nix.hs | 9 +++++++-- src/Stack/Options/Completion.hs | 2 +- src/Stack/Options/GlobalParser.hs | 12 ++++++++++-- src/Stack/Setup.hs | 23 ++++++++++++++-------- src/Stack/Types/Config/Exception.hs | 9 +++++++++ src/Stack/Types/GlobalOpts.hs | 30 +++++++++++++++++------------ src/Stack/Types/Runner.hs | 10 ++++++++++ 11 files changed, 98 insertions(+), 39 deletions(-) diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 1f6b757892..976eadbfb1 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -5,7 +5,7 @@ In connection with considering Stack's support of the [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks to take stock of the errors that Stack itself can raise, by reference to the -`master` branch of the Stack repository. Last updated: 2024-06-03. +`master` branch of the Stack repository. Last updated: 2024-08-02. * `Stack.main`: catches exceptions from action `commandLineHandler`. @@ -424,6 +424,7 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-6854] | BadMsysEnvironment MsysEnvironment Arch [S-5006] | NoDefaultMsysEnvironmentBug [S-8398] | ConfigFileNotProjectLevelBug + [S-6890] | NoExecutablePath String ~~~ - `Stack.Types.Config.ParseAbsolutePathException` diff --git a/src/Stack.hs b/src/Stack.hs index 6dbb15afd8..43cbb01724 100644 --- a/src/Stack.hs +++ b/src/Stack.hs @@ -82,7 +82,8 @@ main = do Left (exitCode :: ExitCode) -> throwIO exitCode Right (globalMonoid, run) -> do - global <- globalOptsFromMonoid isTerminal globalMonoid + global <- + globalOptsFromMonoid progName mExecutablePath isTerminal globalMonoid when (global.logLevel == LevelDebug) $ hPutStrLn stderr versionString' whenJust global.reExecVersion $ \expectVersion -> do diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 4a0157759e..994033ae28 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -66,8 +67,8 @@ import Stack.Types.Compiler ( ActualCompiler (..) ) import Stack.Types.CompilerPaths ( HasCompiler (..), getGhcPkgExe ) import Stack.Types.ComponentUtils ( StackUnqualCompName, unqualCompToString ) -import Stack.Types.Config - ( Config (..), HasConfig (..), buildOptsL ) +import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) +import Stack.Types.Config.Exception ( ConfigPrettyException (..) ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) import Stack.Types.DumpPackage ( DumpPackage (..) ) @@ -87,10 +88,10 @@ import Stack.Types.NamedComponent import Stack.Types.Package ( LocalPackage (..), Package (..), packageIdentifier ) import Stack.Types.Platform ( HasPlatform (..) ) -import Stack.Types.Runner ( HasRunner, terminalL ) +import Stack.Types.Runner + ( HasRunner, mExecutablePathL, progNameL, terminalL ) import Stack.Types.SourceMap ( Target ) import qualified System.Directory as D -import System.Environment ( getExecutablePath ) import qualified System.FilePath as FP -- | Fetch the packages necessary for a build, for example in combination with @@ -282,7 +283,10 @@ copyExecutables exes = do Platform _ Windows -> ".exe" _ -> "" - currExe <- liftIO getExecutablePath -- needed for windows, see below + -- needed for windows, see below + currExe <- view mExecutablePathL >>= \case + Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath + Just currExe -> pure $ toFilePath currExe installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do let strName = unqualCompToString name diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index c56819c86e..a8e6bd54b5 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -69,6 +70,7 @@ import Stack.Storage.User import Stack.Types.Config ( Config (..), HasConfig (..), configProjectRoot, stackRootL ) +import Stack.Types.Config.Exception ( ConfigPrettyException (..) ) import Stack.Types.Docker ( DockerException (..), DockerOpts (..), DockerStackExe (..) , Mount (..), dockerCmdName, dockerContainerPlatform @@ -77,12 +79,13 @@ import Stack.Types.Docker ) import Stack.Types.DockerEntrypoint ( DockerEntrypoint (..), DockerUser (..) ) -import Stack.Types.Runner ( HasDockerEntrypointMVar (..), terminalL ) +import Stack.Types.Runner + ( HasDockerEntrypointMVar (..), mExecutablePathL, progNameL + , terminalL + ) import Stack.Types.Version ( showStackVersion, withinRange ) import System.Environment - ( getArgs, getEnv, getEnvironment, getExecutablePath - , getProgName - ) + ( getArgs, getEnv, getEnvironment, getProgName ) import qualified System.FilePath as FP import System.IO.Error ( isDoesNotExistError ) import qualified System.Posix.User as User @@ -126,18 +129,23 @@ getCmdArgs docker imageInfo isRemoteDocker = do case config.docker.stackExe of Just DockerStackExeHost | config.platform == dockerContainerPlatform -> do - exePath <- resolveFile' =<< liftIO getExecutablePath + exePath <- view mExecutablePathL >>= \case + Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath + Just executablePath -> pure executablePath cmdArgs args exePath | otherwise -> throwIO UnsupportedStackExeHostPlatformException Just DockerStackExeImage -> do - progName <- liftIO getProgName + progName <- view progNameL pure (FP.takeBaseName progName, args, [], []) Just (DockerStackExePath path) -> cmdArgs args path Just DockerStackExeDownload -> exeDownload args Nothing | config.platform == dockerContainerPlatform -> do (exePath, exeTimestamp, misCompatible) <- - do exePath <- resolveFile' =<< liftIO getExecutablePath + do exePath <- view mExecutablePathL >>= \case + Nothing -> + view progNameL >>= prettyThrowM . NoExecutablePath + Just executablePath -> pure executablePath exeTimestamp <- getModificationTime exePath isKnown <- loadDockerImageExeCache diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 9a2de67943..b8def7f745 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,10 +24,12 @@ import Stack.Prelude import Stack.Types.BuildConfig ( wantedCompilerVersionL ) import Stack.Types.Config ( Config (..), HasConfig (..), configProjectRoot ) +import Stack.Types.Config.Exception ( ConfigPrettyException (..) ) import Stack.Types.Docker ( reExecArgName ) +import Stack.Types.Runner ( mExecutablePathL, progNameL ) import Stack.Types.Nix ( NixOpts (..) ) import Stack.Types.Version ( showStackVersion ) -import System.Environment ( getArgs, getExecutablePath, lookupEnv ) +import System.Environment ( getArgs, lookupEnv ) import qualified System.FilePath as F -- | Type representing exceptions thrown by functions exported by the @@ -49,7 +52,9 @@ runShellAndExit = do -- first stack when restarting in the container | otherwise = ("--" ++ reExecArgName ++ "=" ++ showStackVersion) : origArgs - exePath <- liftIO getExecutablePath + exePath <- view mExecutablePathL >>= \case + Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath + Just executablePath -> pure $ toFilePath executablePath config <- view configL envOverride <- view processContextL local (set processContextL envOverride) $ do diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 872970c67e..c0745c3948 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -57,7 +57,7 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do -- If it looks like a flag, skip this more costly completion. ('-': _) -> pure [] _ -> do - go' <- globalOptsFromMonoid False mempty + go' <- globalOptsFromMonoid "" Nothing False mempty let go = go' { logLevel = LevelOther "silent" } withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs index d27eacc930..197de1c617 100644 --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -114,10 +114,16 @@ globalOptsParser currentDir kind = GlobalOptsMonoid -- | Create GlobalOpts from GlobalOptsMonoid. globalOptsFromMonoid :: MonadIO m - => Bool + => String + -- ^ The name of the current Stack executable, as it was invoked. + -> Maybe (Path Abs File) + -- ^ The path to the current Stack executable, if the operating system + -- provides a reliable way to determine it and where a result was + -- available. + -> Bool -> GlobalOptsMonoid -> m GlobalOpts -globalOptsFromMonoid defaultTerminal globalMonoid = do +globalOptsFromMonoid progName mExecutablePath defaultTerminal globalMonoid = do snapshot <- for (getFirst globalMonoid.snapshot) $ \us -> do root <- case globalMonoid.snapshotRoot of @@ -149,6 +155,8 @@ globalOptsFromMonoid defaultTerminal globalMonoid = do , termWidthOpt = getFirst globalMonoid.termWidthOpt , stackYaml , lockFileBehavior + , progName + , mExecutablePath } -- | Default logging level should be something useful but not crazy. diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 4caa343aa9..c8edea6380 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -143,6 +143,7 @@ import Stack.Types.Config ( Config (..), HasConfig (..), envOverrideSettingsL , ghcInstallHook ) +import Stack.Types.Config.Exception ( ConfigPrettyException (..) ) import Stack.Types.DownloadInfo ( DownloadInfo (..) ) import Stack.Types.DumpPackage ( DumpPackage (..) ) import Stack.Types.EnvConfig @@ -163,7 +164,8 @@ import Stack.Types.GlobalOpts ( GlobalOpts (..) ) import Stack.Types.Platform ( HasPlatform (..), PlatformVariant (..) , platformOnlyRelDir ) -import Stack.Types.Runner ( HasRunner (..), Runner (..) ) +import Stack.Types.Runner + ( HasRunner (..), Runner (..), mExecutablePathL, progNameL ) import Stack.Types.SetupInfo ( SetupInfo (..) ) import Stack.Types.SourceMap ( SMActual (..), SMWanted (..), SourceMap (..) ) @@ -173,7 +175,7 @@ import Stack.Types.VersionedDownloadInfo ( VersionedDownloadInfo (..) ) import Stack.Types.WantedCompilerSetter ( WantedCompilerSetter (..) ) import qualified System.Directory as D -import System.Environment ( getExecutablePath, lookupEnv ) +import System.Environment ( lookupEnv ) import System.IO.Error ( isPermissionError ) import System.FilePath ( searchPathSeparator ) import qualified System.FilePath as FP @@ -726,7 +728,9 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath - executablePath <- liftIO getExecutablePath + executablePath <- view mExecutablePathL >>= \case + Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath + Just executablePath -> pure executablePath utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer @@ -751,7 +755,8 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do else id) $ (if es.stackExe - then Map.insert "STACK_EXE" (T.pack executablePath) + then + Map.insert "STACK_EXE" (T.pack $ toFilePath executablePath) else id) $ (if es.localeUtf8 @@ -2948,10 +2953,12 @@ downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do prettyInfoS "Download complete, testing executable." - -- We need to call getExecutablePath before we overwrite the - -- currently running binary: after that, Linux will append - -- (deleted) to the filename. - currExe <- liftIO getExecutablePath >>= parseAbsFile + -- We need to preserve the name of the executable file before we overwrite the + -- currently running binary: after that, Linux will append (deleted) to the + -- filename. + currExe <- view mExecutablePathL >>= \case + Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath + Just executablePath -> pure executablePath liftIO $ do setFileExecutable (toFilePath tmpFile) diff --git a/src/Stack/Types/Config/Exception.hs b/src/Stack/Types/Config/Exception.hs index 956800075b..65269e1bbf 100644 --- a/src/Stack/Types/Config/Exception.hs +++ b/src/Stack/Types/Config/Exception.hs @@ -168,6 +168,7 @@ data ConfigPrettyException | BadMsysEnvironment !MsysEnvironment !Arch | NoMsysEnvironmentBug | ConfigFileNotProjectLevelBug + | NoExecutablePath !String deriving (Show, Typeable) instance Pretty ConfigPrettyException where @@ -238,6 +239,14 @@ instance Pretty ConfigPrettyException where flow "No default MSYS2 environment." pretty ConfigFileNotProjectLevelBug = bugPrettyReport "[S-8398]" $ flow "The configuration file is not a project-level one." + pretty (NoExecutablePath progName) = + "[S-6890]" + <> line + <> fillSep + [ flow "The path for the executable file invoked as" + , style Shell (fromString progName) + , flow "can not be identified." + ] instance Exception ConfigPrettyException diff --git a/src/Stack/Types/GlobalOpts.hs b/src/Stack/Types/GlobalOpts.hs index 455c1f8b5a..7da29e51d5 100644 --- a/src/Stack/Types/GlobalOpts.hs +++ b/src/Stack/Types/GlobalOpts.hs @@ -17,27 +17,33 @@ import Stack.Types.Snapshot ( AbstractSnapshot ) -- | Parsed global command-line options. data GlobalOpts = GlobalOpts - { reExecVersion :: !(Maybe String) + { reExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version , dockerEntrypoint :: !(Maybe DockerEntrypoint) -- ^ Data used when Stack is acting as a Docker entrypoint (internal use -- only) - , logLevel :: !LogLevel -- ^ Log level - , timeInLog :: !Bool -- ^ Whether to include timings in logs. - , rslInLog :: !Bool + , logLevel :: !LogLevel -- ^ Log level + , timeInLog :: !Bool -- ^ Whether to include timings in logs. + , rslInLog :: !Bool -- ^ Whether to include raw snapshot layer (RSL) in logs. - , planInLog :: !Bool + , planInLog :: !Bool -- ^ Whether to include debug information about the construction of the -- build plan in logs. - , configMonoid :: !ConfigMonoid + , configMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' - , snapshot :: !(Maybe AbstractSnapshot) -- ^ Snapshot override - , compiler :: !(Maybe WantedCompiler) -- ^ Compiler override - , terminal :: !Bool -- ^ We're in a terminal? - , stylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles - , termWidthOpt :: !(Maybe Int) -- ^ Terminal width override - , stackYaml :: !StackYamlLoc -- ^ Override project stack.yaml + , snapshot :: !(Maybe AbstractSnapshot) -- ^ Snapshot override + , compiler :: !(Maybe WantedCompiler) -- ^ Compiler override + , terminal :: !Bool -- ^ We're in a terminal? + , stylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles + , termWidthOpt :: !(Maybe Int) -- ^ Terminal width override + , stackYaml :: !StackYamlLoc -- ^ Override project stack.yaml , lockFileBehavior :: !LockFileBehavior + , progName :: !String + -- ^ The name of the current Stack executable, as it was invoked. + , mExecutablePath :: !(Maybe (Path Abs File)) + -- ^ The path to the current Stack executable, if the operating system + -- provides a reliable way to determine it and where a result was + -- available. } globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index a71bd4936e..d6dbb8e1b1 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -13,6 +13,8 @@ module Stack.Types.Runner , terminalL , reExecL , rslInLogL + , progNameL + , mExecutablePathL ) where import RIO.Process ( HasProcessContext (..), ProcessContext ) @@ -91,3 +93,11 @@ reExecL = globalOptsL . to (isJust . (.reExecVersion)) -- | See the @rslInLog@ field of the 'GlobalOpts' data constructor. rslInLogL :: HasRunner env => SimpleGetter env Bool rslInLogL = globalOptsL . to (.rslInLog) + +-- | See the @progNameL@ field of the 'GlobalOpts' data constructor. +progNameL :: HasRunner env => SimpleGetter env String +progNameL = globalOptsL . to (.progName) + +-- | See the @mExecutablePath@ field of the 'GlobalOpts' data constructor. +mExecutablePathL :: HasRunner env => SimpleGetter env (Maybe (Path Abs File)) +mExecutablePathL = globalOptsL . to (.mExecutablePath)