Merge pull request #6631 from commercialhaskell/fix6630

Fix #6630 Also take exectutable file name into account, for '`stack`'

Author: mpilgrem

ChangeLog.md

@@ -21,6 +21,10 @@ Bug fixes:
 * Stack's in-app messages refer to https://haskellstack.org as currently
   structured. (Most URLs in older Stack versions are redirected.)
 
+* Stack's `upgrade` command only treats the current running Stack executable
+  as '`stack`' if the executable file is named `stack` or, on Windows,
+  `stack.exe`. Previously only how it was invoked was considered.
+
 ## v3.1.1 - 2024-07-28
 
 Release notes:

doc/commands/upgrade_command.md

@@ -37,10 +37,11 @@ By default:
   (replacing any existing executable named `stack` there);
 
 * if the current running Stack executable is '`stack`' (that is, it was invoked
-  as `stack` or, on Windows, `stack.exe` - this is case insensitive), an
-  existing binary distribution will replace it. If the executable is located
-  outside of Stack's local binary directory, pass the `--only-local-bin` flag to
-  skip that step;
+  as `stack` or, on Windows, `stack.exe` - this is case insensitive - and the
+  Stack executable file is named `stack` or, on Windows, `stack.exe` - this is
+  case sensitive), an existing binary distribution will replace it. If the
+  executable is located outside of Stack's local binary directory, pass the
+  `--only-local-bin` flag to skip that step;
 
 * if the current running Stack executable is not '`stack`' (as described above),
   an existing binary distribution will only be put in Stack's local binary

src/Stack.hs

@@ -12,6 +12,7 @@ module Stack
 import           Control.Monad.Extra ( whenJust )
 import           GHC.IO.Encoding ( mkTextEncoding, textEncodingName )
 import           Options.Applicative.Builder.Extra ( execExtraHelp )
+import           Path ( parseAbsFile )
 import           Stack.BuildInfo ( versionString' )
 import           Stack.CLI ( commandLineHandler )
 import           Stack.Constants ( stackProgName )
@@ -30,7 +31,7 @@ import           Stack.Types.Version
                    , stackVersion
                    )
 import           System.Directory ( getCurrentDirectory )
-import           System.Environment ( getArgs, getProgName )
+import           System.Environment ( executablePath, getArgs, getProgName )
 import           System.IO ( hGetEncoding, hPutStrLn, hSetEncoding )
 import           System.Terminal ( hIsTerminalDeviceOrMinTTY )
 
@@ -61,6 +62,8 @@ main = do
   hSetTranslit stderr
   args <- getArgs
   progName <- getProgName
+  mExecutableFilePath <- fromMaybe (pure Nothing) executablePath
+  let mExecutablePath = mExecutableFilePath >>= parseAbsFile
   isTerminal <- hIsTerminalDeviceOrMinTTY stdout
   execExtraHelp
     args
@@ -73,7 +76,8 @@ main = do
     (nixOptsParser False)
     ("Only showing --" ++ nixCmdName ++ "* options.")
   currentDir <- getCurrentDirectory
-  eGlobalRun <- try $ commandLineHandler currentDir progName False
+  eGlobalRun <-
+    try $ commandLineHandler currentDir progName mExecutablePath False
   case eGlobalRun of
     Left (exitCode :: ExitCode) ->
       throwIO exitCode

src/Stack/CLI.hs

@@ -18,6 +18,7 @@ import           Options.Applicative.Builder.Extra
                    ( boolFlags, extraHelpOption )
 import           Options.Applicative.Complicated
                    ( addCommand, addSubCommands, complicatedOptions )
+import           Path ( filename )
 import           RIO.NonEmpty ( (<|) )
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Process ( exec )
@@ -26,7 +27,10 @@ import           Stack.Build ( buildCmd )
 import           Stack.BuildInfo ( hpackVersion, versionString' )
 import           Stack.Clean ( CleanCommand (..), cleanCmd )
 import           Stack.ConfigCmd as ConfigCmd
-import           Stack.Constants ( globalFooter, osIsWindows, stackProgName )
+import           Stack.Constants
+                   ( globalFooter, osIsWindows, relFileStack, relFileStackDotExe
+                   , stackProgName
+                   )
 import           Stack.Coverage ( hpcReportCmd )
 import           Stack.Docker
                    ( dockerCmdName, dockerHelpOptName, dockerPullCmdName )
@@ -84,7 +88,7 @@ import           Stack.Update ( updateCmd )
 import           Stack.Upgrade ( upgradeCmd )
 import           Stack.Upload ( uploadCmd )
 import qualified System.Directory as D
-import           System.Environment ( getProgName, withArgs )
+import           System.Environment ( withArgs )
 import           System.FilePath ( pathSeparator, takeDirectory )
 
 -- | Type representing \'pretty\' exceptions thrown by functions in the
@@ -103,9 +107,14 @@ instance Exception CliPrettyException
 commandLineHandler ::
      FilePath
   -> 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
   -> IO (GlobalOptsMonoid, RIO Runner ())
-commandLineHandler currentDir progName isInterpreter =
+commandLineHandler currentDir progName mExecutablePath isInterpreter =
   -- Append the relevant default (potentially affecting the LogLevel) *after*
   -- appending the global options of the `stack` command to the global options
   -- of the subcommand - see #5326.
@@ -136,7 +145,7 @@ commandLineHandler currentDir progName isInterpreter =
               parseResultHandler (NE.toList args') f
             else
               secondaryCommandHandler args' f
-                >>= interpreterHandler currentDir args'
+                >>= interpreterHandler progName mExecutablePath currentDir args'
         )
         (NE.nonEmpty args)
       Nothing -> parseResultHandler args f
@@ -516,11 +525,18 @@ commandLineHandler currentDir progName isInterpreter =
     \upgrade Stack."
     (upgradeOptsParser onlyLocalBins)
    where
-    onlyLocalBins =
-         (lowercase progName /= lowercase stackProgName)
-      && not ( osIsWindows
-             && lowercase progName == lowercase (stackProgName <> ".EXE")
-             )
+    isProgNameStack =
+         (lowercase progName == lowercase stackProgName)
+      || (  osIsWindows
+         && lowercase progName == lowercase (stackProgName <> ".EXE")
+         )
+    isRelFileNameStack relFile =
+         (relFile == relFileStack)
+      || (osIsWindows && relFile == relFileStackDotExe )
+    isExecutableNameStack =
+      let mExecutableName = filename <$> mExecutablePath
+      in  maybe False isRelFileNameStack mExecutableName
+    onlyLocalBins = not (isProgNameStack && isExecutableNameStack)
     lowercase = map toLower
 
   upload = addCommand'
@@ -669,11 +685,17 @@ secondaryCommandHandler args f =
 
 interpreterHandler ::
      Monoid t
-  => FilePath
+  => 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.
+  -> FilePath
   -> NonEmpty String
   -> ParserFailure ParserHelp
   -> IO (GlobalOptsMonoid, (RIO Runner (), t))
-interpreterHandler currentDir args f = do
+interpreterHandler progName mExecutablePath currentDir args f = do
   -- args can include top-level config such as --extra-lib-dirs=... (set by
   -- nix-shell) - we need to find the first argument which is a file, everything
   -- afterwards is an argument to the script, everything before is an argument
@@ -711,9 +733,9 @@ interpreterHandler currentDir args f = do
     ("File does not exist or is not a regular file '" ++ name ++ "'.")
 
   runInterpreterCommand path stackArgs fileArgs = do
-    progName <- getProgName
     iargs <- getInterpreterArgs path
-    let parseCmdLine = commandLineHandler currentDir progName True
+    let parseCmdLine =
+          commandLineHandler currentDir progName mExecutablePath True
         -- Implicit file arguments are put before other arguments that
         -- occur after "--". See #3658
         cmdArgs = prependList stackArgs $ case NE.break (== "--") iargs of