Merge pull request #6119 from commercialhaskell/fix3708

Fix #3708 By default, don't overwrite a Stack executable not named stack

Author: mpilgrem

ChangeLog.md

@@ -10,6 +10,13 @@ Major changes:
 
 Behavior changes:
 
+* Add flag `--[no-]-only-local-bin` to Stack's `upgrade` command for a binary
+  upgrade. If the Stack executable is `my-stack`, the default is
+  `my-stack upgrade --only-local-bin` where previously it was, effectively,
+  `my-stack upgrade --no-only-local-bin`. If the Stack executable is `stack`,
+  the default is `stack upgrade --no-only-local-bin`, the same behaviour as
+  previously.
+
 * Use `$XDG_CACHE_HOME/stack/ghci-script`, rather than `<temp>/haskell-stack-ghci`
   (where `<temp>` is the directory yielded by the `temporary` package's
   `System.IO.Temp.getCanonicalTemporaryDirectory`), as the base location for

doc/upgrade_command.md

@@ -6,7 +6,8 @@ Either:
 
 ~~~text
 stack upgrade [--binary-only] [--binary-platform ARG] [--force-download]
-              [--binary-version ARG] [--github-org ARG] [--github-repo ARG]
+              [--[no-]only-local-bin] [--binary-version ARG] [--github-org ARG]
+              [--github-repo ARG]
 ~~~
 
 or:
@@ -26,6 +27,20 @@ By default:
 * the new version will not overwrite the existing version unless it is newer.
   Pass the `--force-download` flag to force a download;
 
+* when an existing binary distribution is applicable, it will be put in Stack's
+  local binary directory (see `stack path --local-bin`) and named `stack`
+  (replacing any existing executable named `stack` there);
+
+* if the current running Stack executable is named `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;
+
+* if the current running Stack executable is named other than `stack` (and, on
+  Windows, `stack.exe`), an existing binary distribution will only be put in
+  Stack's local binary directory and named `stack`. Pass the
+  `--no-only-local-bin` flag to replace also the current running executable;
+
 * the new version will be the latest available. Pass the
   `--binary-version <version>` option to specify the version (this implies
   `--force-download`);
@@ -39,15 +54,8 @@ By default:
   repository; and
 
 * the binary distribution will be sought for the current platform. Pass the
-  `--binary-platform <platform>` option to specify a different platform (`<operating_system>-<architecture>-<suffix>`).
-
-When applicable, an existing binary distribution will be:
-
-* put in Stack's local binary directory (see `stack path --local-bin`) and named
-  `stack` (replacing any existing executable there named `stack`); and
-
-* (if different) named the same as, and replace, the current running Stack
-  executable.
+  `--binary-platform <platform>` option to specify a different platform
+  (`<operating_system>-<architecture>-<suffix>`).
 
 When compiling from source code, by default:
 
@@ -65,13 +73,19 @@ When compiling from source code, by default:
 * `stack upgrade --force-download` seeks an upgrade to the latest version of
   Stack available as a binary distribution for the platform, even if not newer.
 
+* If the Stack executable is named `my-stack`, `my-stack upgrade` seeks only to
+  put the latest version of Stack available as a binary distribution for the
+  platform, if newer, in Stack's local binary directory and name it `stack`.
+  `my-stack upgrade --no-only-local-bin` seeks also to upgrade `my-stack` to the
+  latest version of Stack available.
+
 * `stack upgrade --binary-version 2.11.1` seeks an upgrade to Stack 2.11.1 if
   available as a binary distribution for the platform, even if not newer.
 
 * `stack upgrade --source-only` seeks an upgrade by building Stack with
-   Stack from the latest version of the source code in the package index
-   (i.e. Hackage).
+  Stack from the latest version of the source code in the package index
+  (i.e. Hackage).
 
 * `stack upgrade --source-only --git` seeks an upgrade by building Stack with
-   Stack from the latest version of the source code in the `master` branch of
-   Stack's repository.
+  Stack from the latest version of the source code in the `master` branch of
+  Stack's repository.

src/Stack/Options/UpgradeParser.hs

@@ -6,16 +6,20 @@ module Stack.Options.UpgradeParser
   ) where
 
 import         Options.Applicative
-                 ( Parser, flag', help, long, metavar, showDefault, strOption
-                 , switch, value
+                 ( Parser, flag', help, idm, long, metavar, showDefault
+                 , strOption, switch, value
                  )
+import         Options.Applicative.Builder.Extra ( boolFlags )
 import         Stack.Prelude
 import         Stack.Upgrade
                  ( BinaryOpts (..), SourceOpts (..), UpgradeOpts (..) )
 
 -- | Parse command line arguments for Stack's @upgrade@ command.
-upgradeOptsParser :: Parser UpgradeOpts
-upgradeOptsParser = UpgradeOpts
+upgradeOptsParser ::
+     Bool
+     -- ^ The default for --[no]-only-local-bin
+  -> Parser UpgradeOpts
+upgradeOptsParser onlyLocalBin = UpgradeOpts
   <$> (sourceOnly <|> optional binaryOpts)
   <*> (binaryOnly <|> optional sourceOpts)
  where
@@ -39,6 +43,10 @@ upgradeOptsParser = UpgradeOpts
           <> help "Download the latest available Stack executable, even if not \
                   \newer."
           )
+    <*> boolFlags onlyLocalBin
+          "only-local-bin"
+          "downloading only to Stack's local binary directory"
+          idm
     <*> optional (strOption
           (  long "binary-version"
           <> help "Download a specific Stack version, even if already \

src/Stack/Upgrade.hs

@@ -92,10 +92,12 @@ instance Exception UpgradePrettyException
 data BinaryOpts = BinaryOpts
   { _boPlatform :: !(Maybe String)
   , _boForce :: !Bool
-    -- ^ force a download, even if the downloaded version is older than what we
-    -- are
+    -- ^ Force a download, even if the downloaded version is older than what we
+    -- are.
+  , _boOnlyLocalBin :: !Bool
+    -- ^ Only download to Stack's local binary directory.
   , _boVersion :: !(Maybe String)
-    -- ^ specific version to download
+    -- ^ Specific version to download
   , _boGitHubOrg :: !(Maybe String)
   , _boGitHubRepo :: !(Maybe String)
   }
@@ -146,7 +148,7 @@ upgrade builtHash (UpgradeOpts mbo mso) = case (mbo, mso) of
   source = sourceUpgrade builtHash
 
 binaryUpgrade :: BinaryOpts -> RIO Runner ()
-binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) =
+binaryUpgrade (BinaryOpts mplatform force' onlyLocalBin mver morg mrepo) =
   withConfig NoReexec $ do
     platforms0 <-
       case mplatform of
@@ -194,11 +196,12 @@ binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) =
         pure True
     when toUpgrade $ do
       config <- view configL
-      downloadStackExe platforms0 archiveInfo (configLocalBin config) True $
-        \tmpFile -> do
-          -- Sanity check!
-          ec <- rawSystem (toFilePath tmpFile) ["--version"]
-          unless (ec == ExitSuccess) (prettyThrowIO ExecutableFailure)
+      downloadStackExe
+        platforms0 archiveInfo (configLocalBin config) (not onlyLocalBin) $
+          \tmpFile -> do
+            -- Sanity check!
+            ec <- rawSystem (toFilePath tmpFile) ["--version"]
+            unless (ec == ExitSuccess) (prettyThrowIO ExecutableFailure)
 
 sourceUpgrade ::
      Maybe String

src/main/Stack/CLI.hs

@@ -6,6 +6,7 @@ module Stack.CLI
 
 import           BuildInfo ( hpackVersion, versionString' )
 import           Data.Attoparsec.Interpreter ( getInterpreterArgs )
+import           Data.Char ( toLower )
 import qualified Data.List as L
 import           Options.Applicative
                    ( Parser, ParserFailure, ParserHelp, ParserResult (..), flag
@@ -21,7 +22,7 @@ import           RIO.Process ( withProcessContextNoLogging )
 import           Stack.Build ( buildCmd )
 import           Stack.Clean ( CleanCommand (..), cleanCmd )
 import           Stack.ConfigCmd as ConfigCmd
-import           Stack.Constants ( globalFooter, stackProgName )
+import           Stack.Constants ( globalFooter, osIsWindows, stackProgName )
 import           Stack.Coverage ( hpcReportCmd )
 import           Stack.Docker
                    ( dockerCmdName, dockerHelpOptName, dockerPullCmdName )
@@ -483,7 +484,14 @@ commandLineHandler currentDir progName isInterpreter =
     upgradeCmd
     "Warning: if you use GHCup to install Stack, use only GHCup to \
     \upgrade Stack."
-    upgradeOptsParser
+    (upgradeOptsParser onlyLocalBins)
+   where
+    onlyLocalBins =
+         (lowercase progName /= lowercase stackProgName)
+      && not ( osIsWindows
+             && lowercase progName == lowercase (stackProgName <> ".EXE")
+             )
+    lowercase = map toLower
 
   upload = addCommand'
     "upload"