{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

-- | Types and functions related to Stack's @upgrade@ command.

module Stack.Upgrade
  ( UpgradeOpts (..)
  , BinaryOpts (..)
  , SourceOpts (..)
  , upgradeCmd
  , upgrade
  ) where

import qualified Data.Text as T
import           Path ( (</>), parseRelDir )
import           RIO.Process ( proc, runProcess_, withWorkingDir )
import           Stack.Build ( build )
import           Stack.Build.Target ( NeedTargets (..) )
import           Stack.BuildInfo ( maybeGitHash )
import           Stack.Constants ( relDirStackProgName, stackDotYaml )
import           Stack.Prelude hiding ( force, Display (..) )
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withEnvConfig
                   , withGlobalProject )
import           Stack.Setup
                   ( downloadStackExe, downloadStackReleaseInfo
                   , getDownloadVersion, preferredPlatforms, stackVersion
                   )
import           Stack.Types.BuildOpts ( buildOptsInstallExesL )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import           System.Process ( rawSystem, readProcess )

-- | Type representing \'pretty\' exceptions thrown by functions in the

-- "Stack.Upgrade" module.

data UpgradePrettyException
  = ResolverOptionInvalid
  | NeitherBinaryOrSourceSpecified
  | ExecutableFailure
  | CommitsNotFound String String
  | StackInPackageIndexNotFound
  | VersionWithNoRevision
  deriving (Int -> UpgradePrettyException -> ShowS
[UpgradePrettyException] -> ShowS
UpgradePrettyException -> String
(Int -> UpgradePrettyException -> ShowS)
-> (UpgradePrettyException -> String)
-> ([UpgradePrettyException] -> ShowS)
-> Show UpgradePrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpgradePrettyException -> ShowS
showsPrec :: Int -> UpgradePrettyException -> ShowS
$cshow :: UpgradePrettyException -> String
show :: UpgradePrettyException -> String
$cshowList :: [UpgradePrettyException] -> ShowS
showList :: [UpgradePrettyException] -> ShowS
Show, Typeable)

instance Pretty UpgradePrettyException where
  pretty :: UpgradePrettyException -> StyleDoc
pretty UpgradePrettyException
ResolverOptionInvalid =
    StyleDoc
"[S-8761]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"The"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--resolver"
         , String -> StyleDoc
flow String
"option cannot be used with Stack's"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"upgrade"
         , StyleDoc
"command."
         ]
  pretty UpgradePrettyException
NeitherBinaryOrSourceSpecified =
    StyleDoc
"[S-3642]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You must allow either binary or source upgrade paths."
  pretty UpgradePrettyException
ExecutableFailure =
    StyleDoc
"[S-8716]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Non-success exit code from running newly downloaded executable."
  pretty (CommitsNotFound String
branch String
repo) =
    StyleDoc
"[S-7114]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"No commits found for branch"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
branch)
         , String -> StyleDoc
flow String
"on repo"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
repo) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty UpgradePrettyException
StackInPackageIndexNotFound =
    StyleDoc
"[S-9668]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"No Stack version found in package indices."
  pretty UpgradePrettyException
VersionWithNoRevision =
    StyleDoc
"[S-6648]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Latest version with no revision."

instance Exception UpgradePrettyException

-- | Type representing options for upgrading Stack with a binary executable

-- file.

data BinaryOpts = BinaryOpts
  { BinaryOpts -> Maybe String
platform :: !(Maybe String)
  , BinaryOpts -> Bool
force :: !Bool
    -- ^ Force a download, even if the downloaded version is older than what we

    -- are.

  , BinaryOpts -> Bool
onlyLocalBin :: !Bool
    -- ^ Only download to Stack's local binary directory.

  , BinaryOpts -> Maybe String
version :: !(Maybe String)
    -- ^ Specific version to download

  , BinaryOpts -> Maybe String
gitHubOrg :: !(Maybe String)
  , BinaryOpts -> Maybe String
gitHubRepo :: !(Maybe String)
  }
  deriving Int -> BinaryOpts -> ShowS
[BinaryOpts] -> ShowS
BinaryOpts -> String
(Int -> BinaryOpts -> ShowS)
-> (BinaryOpts -> String)
-> ([BinaryOpts] -> ShowS)
-> Show BinaryOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BinaryOpts -> ShowS
showsPrec :: Int -> BinaryOpts -> ShowS
$cshow :: BinaryOpts -> String
show :: BinaryOpts -> String
$cshowList :: [BinaryOpts] -> ShowS
showList :: [BinaryOpts] -> ShowS
Show

-- | Type representing options for upgrading Stack from source code.

newtype SourceOpts
  = SourceOpts (Maybe (String, String)) -- repo and branch

  deriving Int -> SourceOpts -> ShowS
[SourceOpts] -> ShowS
SourceOpts -> String
(Int -> SourceOpts -> ShowS)
-> (SourceOpts -> String)
-> ([SourceOpts] -> ShowS)
-> Show SourceOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SourceOpts -> ShowS
showsPrec :: Int -> SourceOpts -> ShowS
$cshow :: SourceOpts -> String
show :: SourceOpts -> String
$cshowList :: [SourceOpts] -> ShowS
showList :: [SourceOpts] -> ShowS
Show

-- | Type representing command line options for the @stack upgrade@ command.

data UpgradeOpts = UpgradeOpts
  { UpgradeOpts -> Maybe BinaryOpts
binary :: !(Maybe BinaryOpts)
  , UpgradeOpts -> Maybe SourceOpts
source :: !(Maybe SourceOpts)
  }
  deriving Int -> UpgradeOpts -> ShowS
[UpgradeOpts] -> ShowS
UpgradeOpts -> String
(Int -> UpgradeOpts -> ShowS)
-> (UpgradeOpts -> String)
-> ([UpgradeOpts] -> ShowS)
-> Show UpgradeOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpgradeOpts -> ShowS
showsPrec :: Int -> UpgradeOpts -> ShowS
$cshow :: UpgradeOpts -> String
show :: UpgradeOpts -> String
$cshowList :: [UpgradeOpts] -> ShowS
showList :: [UpgradeOpts] -> ShowS
Show

-- | Function underlying the @stack upgrade@ command.

upgradeCmd :: UpgradeOpts -> RIO Runner ()
upgradeCmd :: UpgradeOpts -> RIO Runner ()
upgradeCmd UpgradeOpts
upgradeOpts = do
  GlobalOpts
go <- Getting GlobalOpts Runner GlobalOpts -> RIO Runner GlobalOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GlobalOpts Runner GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL
  case GlobalOpts
go.resolver of
    Just AbstractResolver
_ -> UpgradePrettyException -> RIO Runner ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UpgradePrettyException
ResolverOptionInvalid
    Maybe AbstractResolver
Nothing -> RIO Runner () -> RIO Runner ()
forall a. RIO Runner a -> RIO Runner a
withGlobalProject (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> UpgradeOpts -> RIO Runner ()
upgrade Maybe String
maybeGitHash UpgradeOpts
upgradeOpts

upgrade ::
     Maybe String -- ^ git hash at time of building, if known

  -> UpgradeOpts
  -> RIO Runner ()
upgrade :: Maybe String -> UpgradeOpts -> RIO Runner ()
upgrade Maybe String
builtHash (UpgradeOpts Maybe BinaryOpts
mbo Maybe SourceOpts
mso) = case (Maybe BinaryOpts
mbo, Maybe SourceOpts
mso) of
  -- FIXME It would be far nicer to capture this case in the options parser

  -- itself so we get better error messages, but I can't think of a way to

  -- make it happen.

  (Maybe BinaryOpts
Nothing, Maybe SourceOpts
Nothing) -> UpgradePrettyException -> RIO Runner ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UpgradePrettyException
NeitherBinaryOrSourceSpecified
  (Just BinaryOpts
bo, Maybe SourceOpts
Nothing) -> BinaryOpts -> RIO Runner ()
binary BinaryOpts
bo
  (Maybe BinaryOpts
Nothing, Just SourceOpts
so) -> SourceOpts -> RIO Runner ()
source SourceOpts
so
  -- See #2977 - if --git or --git-repo is specified, do source upgrade.

  (Maybe BinaryOpts
_, Just so :: SourceOpts
so@(SourceOpts (Just (String, String)
_))) -> SourceOpts -> RIO Runner ()
source SourceOpts
so
  (Just BinaryOpts
bo, Just SourceOpts
so) -> BinaryOpts -> RIO Runner ()
binary BinaryOpts
bo RIO Runner () -> (SomeException -> RIO Runner ()) -> RIO Runner ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
    StyleDoc -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO Runner ()) -> StyleDoc -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"When trying to perform binary upgrade, Stack encountered the \
              \following error:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> SomeException -> StyleDoc
ppException SomeException
e
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Falling back to source upgrade."
    SourceOpts -> RIO Runner ()
source SourceOpts
so
 where
  binary :: BinaryOpts -> RIO Runner ()
binary = BinaryOpts -> RIO Runner ()
binaryUpgrade
  source :: SourceOpts -> RIO Runner ()
source = Maybe String -> SourceOpts -> RIO Runner ()
sourceUpgrade Maybe String
builtHash

binaryUpgrade :: BinaryOpts -> RIO Runner ()
binaryUpgrade :: BinaryOpts -> RIO Runner ()
binaryUpgrade (BinaryOpts Maybe String
mplatform Bool
force' Bool
onlyLocalBin Maybe String
mver Maybe String
morg Maybe String
mrepo) =
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ do
    [(Bool, String)]
platforms0 <-
      case Maybe String
mplatform of
        Maybe String
Nothing -> RIO Config [(Bool, String)]
forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m [(Bool, String)]
preferredPlatforms
        Just String
p -> [(Bool, String)] -> RIO Config [(Bool, String)]
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text
"windows" Text -> Text -> Bool
`T.isInfixOf` String -> Text
T.pack String
p, String
p)]
    StackReleaseInfo
archiveInfo <- Maybe String
-> Maybe String -> Maybe String -> RIO Config StackReleaseInfo
forall env.
(HasLogFunc env, HasPlatform env) =>
Maybe String
-> Maybe String -> Maybe String -> RIO env StackReleaseInfo
downloadStackReleaseInfo Maybe String
morg Maybe String
mrepo Maybe String
mver
    let mdownloadVersion :: Maybe Version
mdownloadVersion = StackReleaseInfo -> Maybe Version
getDownloadVersion StackReleaseInfo
archiveInfo
        force :: Bool
force =
          case Maybe String
mver of
            Maybe String
Nothing -> Bool
force'
            Just String
_ -> Bool
True -- specifying a version implies we're forcing things

    Bool
isNewer <-
      case Maybe Version
mdownloadVersion of
        Maybe Version
Nothing -> do
          StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
               String -> StyleDoc
flow String
"Unable to determine upstream version from GitHub metadata."
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if Bool
force
                 then StyleDoc
forall a. Monoid a => a
mempty
                 else
                      StyleDoc
line
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                        [ String -> StyleDoc
flow String
"Rerun with"
                        , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--force-download"
                        , String -> StyleDoc
flow String
"to force an upgrade."
                        ]
          Bool -> RIO Config Bool
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just Version
downloadVersion -> do
          [StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Current Stack version:"
            , String -> StyleDoc
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
stackVersion) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
";"
            , String -> StyleDoc
flow String
"available download version:"
            , String -> StyleDoc
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
downloadVersion) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]
          Bool -> RIO Config Bool
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO Config Bool) -> Bool -> RIO Config Bool
forall a b. (a -> b) -> a -> b
$ Version
downloadVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
stackVersion
    Bool
toUpgrade <- case (Bool
force, Bool
isNewer) of
      (Bool
False, Bool
False) -> do
        String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Skipping binary upgrade, you are already running the most \
                    \recent version."
        Bool -> RIO Config Bool
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      (Bool
True, Bool
False) -> do
        String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Forcing binary upgrade."
        Bool -> RIO Config Bool
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      (Bool
_, Bool
True) -> do
        String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Newer version detected, downloading."
        Bool -> RIO Config Bool
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toUpgrade (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
      Config
config <- Getting Config Config Config -> RIO Config Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Config Config
forall env. HasConfig env => Lens' env Config
Lens' Config Config
configL
      [(Bool, String)]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO Config ()
forall env.
HasConfig env =>
[(Bool, String)]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO env ()
downloadStackExe
        [(Bool, String)]
platforms0 StackReleaseInfo
archiveInfo Config
config.localBin (Bool -> Bool
not Bool
onlyLocalBin) ((Path Abs File -> IO ()) -> RIO Config ())
-> (Path Abs File -> IO ()) -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
          \Path Abs File
tmpFile -> do
            -- Sanity check!

            ExitCode
ec <- String -> [String] -> IO ExitCode
rawSystem (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tmpFile) [String
"--version"]
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (UpgradePrettyException -> IO ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UpgradePrettyException
ExecutableFailure)

sourceUpgrade ::
     Maybe String
  -> SourceOpts
  -> RIO Runner ()
sourceUpgrade :: Maybe String -> SourceOpts -> RIO Runner ()
sourceUpgrade Maybe String
builtHash (SourceOpts Maybe (String, String)
gitRepo) =
  String -> (Path Abs Dir -> RIO Runner ()) -> RIO Runner ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir String
"stack-upgrade" ((Path Abs Dir -> RIO Runner ()) -> RIO Runner ())
-> (Path Abs Dir -> RIO Runner ()) -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmp -> do
    Maybe (Path Abs Dir)
mdir <- case Maybe (String, String)
gitRepo of
      Just (String
repo, String
branch) -> do
        String
remote <- IO String -> RIO Runner String
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO Runner String) -> IO String -> RIO Runner String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
System.Process.readProcess
          String
"git"
          [String
"ls-remote", String
repo, String
branch]
          []
        String
latestCommit <-
          case String -> [String]
words String
remote of
            [] -> UpgradePrettyException -> RIO Runner String
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (UpgradePrettyException -> RIO Runner String)
-> UpgradePrettyException -> RIO Runner String
forall a b. (a -> b) -> a -> b
$ String -> String -> UpgradePrettyException
CommitsNotFound String
branch String
repo
            String
x:[String]
_ -> String -> RIO Runner String
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
x
        Bool -> RIO Runner () -> RIO Runner ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
builtHash) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
          String -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyWarnS
            String
"Information about the commit this version of Stack was built from \
            \is not available due to how it was built. Will continue by \
            \assuming an upgrade is needed because we have no information to \
            \the contrary."
        if Maybe String
builtHash Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
latestCommit
            then do
              String -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Already up-to-date, no upgrade required."
              Maybe (Path Abs Dir) -> RIO Runner (Maybe (Path Abs Dir))
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
            else do
              String -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Cloning stack."
              -- NOTE: "--recursive" was added after v1.0.0 (and before the next

              -- release).  This means that we can't use submodules in the Stack

              -- repo until we're comfortable with "stack upgrade --git" not

              -- working for earlier versions.

              let args :: [String]
args =
                    [ String
"clone"
                    , String
repo
                    , String
"stack"
                    , String
"--depth"
                    , String
"1"
                    , String
"--recursive"
                    , String
"--branch"
                    , String
branch
                    ]
              String -> RIO Runner () -> RIO Runner ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
tmp) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> (ProcessConfig () () () -> RIO Runner ())
-> RIO Runner ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"git" [String]
args ProcessConfig () () () -> RIO Runner ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
              Maybe (Path Abs Dir) -> RIO Runner (Maybe (Path Abs Dir))
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs Dir) -> RIO Runner (Maybe (Path Abs Dir)))
-> Maybe (Path Abs Dir) -> RIO Runner (Maybe (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
tmp Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirStackProgName
      -- We need to access the Pantry database to find out about the latest

      -- Stack available on Hackage. We first use a standard Config to do this,

      -- and once we have the source load up the stack.yaml from inside that

      -- source.

      Maybe (String, String)
Nothing -> ShouldReexec
-> RIO Config (Maybe (Path Abs Dir))
-> RIO Runner (Maybe (Path Abs Dir))
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config (Maybe (Path Abs Dir))
 -> RIO Runner (Maybe (Path Abs Dir)))
-> RIO Config (Maybe (Path Abs Dir))
-> RIO Runner (Maybe (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$ do
        RIO Config DidUpdateOccur -> RIO Config ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          (RIO Config DidUpdateOccur -> RIO Config ())
-> RIO Config DidUpdateOccur -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ Maybe Utf8Builder -> RIO Config DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex
          (Maybe Utf8Builder -> RIO Config DidUpdateOccur)
-> Maybe Utf8Builder -> RIO Config DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just Utf8Builder
"Updating index to make sure we find the latest Stack version."
        Maybe PackageIdentifierRevision
mversion <- RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO Config (Maybe PackageIdentifierRevision)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion
          RequireHackageIndex
YesRequireHackageIndex
          PackageName
"stack"
          UsePreferredVersions
UsePreferredVersions
        (PackageIdentifierRevision PackageName
_ Version
version CabalFileInfo
_) <-
          case Maybe PackageIdentifierRevision
mversion of
            Maybe PackageIdentifierRevision
Nothing -> UpgradePrettyException -> RIO Config PackageIdentifierRevision
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UpgradePrettyException
StackInPackageIndexNotFound
            Just PackageIdentifierRevision
version -> PackageIdentifierRevision -> RIO Config PackageIdentifierRevision
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifierRevision
version
        if Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
stackVersion
          then do
            String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS String
"Already at latest version, no upgrade required."
            Maybe (Path Abs Dir) -> RIO Config (Maybe (Path Abs Dir))
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
          else do
            Path Rel Dir
suffix <- String -> RIO Config (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> RIO Config (Path Rel Dir))
-> String -> RIO Config (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ String
"stack-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
versionString Version
version
            let dir :: Path Abs Dir
dir = Path Abs Dir
tmp Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
suffix
            Maybe (Revision, BlobKey, TreeKey)
mrev <- RequireHackageIndex
-> PackageName
-> Version
-> RIO Config (Maybe (Revision, BlobKey, TreeKey))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision
              RequireHackageIndex
YesRequireHackageIndex
              PackageName
"stack"
              Version
version
            case Maybe (Revision, BlobKey, TreeKey)
mrev of
              Maybe (Revision, BlobKey, TreeKey)
Nothing -> UpgradePrettyException -> RIO Config (Maybe (Path Abs Dir))
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UpgradePrettyException
VersionWithNoRevision
              Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> do
                let ident :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
"stack" Version
version
                Path Abs Dir -> PackageLocationImmutable -> RIO Config ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
dir (PackageLocationImmutable -> RIO Config ())
-> PackageLocationImmutable -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage PackageIdentifier
ident BlobKey
cfKey TreeKey
treeKey
                Maybe (Path Abs Dir) -> RIO Config (Maybe (Path Abs Dir))
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs Dir) -> RIO Config (Maybe (Path Abs Dir)))
-> Maybe (Path Abs Dir) -> RIO Config (Maybe (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
dir

    let modifyGO :: Path Abs Dir -> GlobalOpts -> GlobalOpts
modifyGO Path Abs Dir
dir GlobalOpts
go = GlobalOpts
go
          { resolver = Nothing -- always use the resolver settings in the

                                     -- stack.yaml file

          , stackYaml = SYLOverride $ dir </> stackDotYaml
          }
        boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI { targetsCLI = ["stack"] }
    Maybe (Path Abs Dir)
-> (Path Abs Dir -> RIO Runner ()) -> RIO Runner ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs Dir)
mdir ((Path Abs Dir -> RIO Runner ()) -> RIO Runner ())
-> (Path Abs Dir -> RIO Runner ()) -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
      (Runner -> Runner) -> RIO Runner () -> RIO Runner ()
forall a. (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL (Path Abs Dir -> GlobalOpts -> GlobalOpts
modifyGO Path Abs Dir
dir))
        (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec
        (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI
        (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> EnvConfig) -> RIO EnvConfig () -> RIO EnvConfig ()
forall a.
(EnvConfig -> EnvConfig) -> RIO EnvConfig a -> RIO EnvConfig a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter EnvConfig EnvConfig Bool Bool
-> Bool -> EnvConfig -> EnvConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ((BuildOpts -> Identity BuildOpts)
-> EnvConfig -> Identity EnvConfig
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL ((BuildOpts -> Identity BuildOpts)
 -> EnvConfig -> Identity EnvConfig)
-> ((Bool -> Identity Bool) -> BuildOpts -> Identity BuildOpts)
-> ASetter EnvConfig EnvConfig Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool) -> BuildOpts -> Identity BuildOpts
Lens' BuildOpts Bool
buildOptsInstallExesL) Bool
True)
        (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing