{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
module Stack.Upgrade
    ( upgrade
    , UpgradeOpts
    , upgradeOpts
    ) where

import           Stack.Prelude               hiding (force, Display (..))
import qualified Data.Text as T
import           Distribution.Version        (mkVersion')
import           Options.Applicative
import           Path
import qualified Paths_stack as Paths
import           Stack.Build
import           Stack.Build.Target (NeedTargets(..))
import           Stack.Constants
import           Stack.Runners
import           Stack.Setup
import           Stack.Types.Config
import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
import           System.Process              (rawSystem, readProcess)
import           RIO.PrettyPrint
import           RIO.Process

upgradeOpts :: Parser UpgradeOpts
upgradeOpts :: Parser UpgradeOpts
upgradeOpts = Maybe BinaryOpts -> Maybe SourceOpts -> UpgradeOpts
UpgradeOpts
    (Maybe BinaryOpts -> Maybe SourceOpts -> UpgradeOpts)
-> Parser (Maybe BinaryOpts)
-> Parser (Maybe SourceOpts -> UpgradeOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Maybe BinaryOpts)
forall a. Parser (Maybe a)
sourceOnly Parser (Maybe BinaryOpts)
-> Parser (Maybe BinaryOpts) -> Parser (Maybe BinaryOpts)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser BinaryOpts -> Parser (Maybe BinaryOpts)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser BinaryOpts
binaryOpts)
    Parser (Maybe SourceOpts -> UpgradeOpts)
-> Parser (Maybe SourceOpts) -> Parser UpgradeOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser (Maybe SourceOpts)
forall a. Parser (Maybe a)
binaryOnly Parser (Maybe SourceOpts)
-> Parser (Maybe SourceOpts) -> Parser (Maybe SourceOpts)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SourceOpts -> Parser (Maybe SourceOpts)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser SourceOpts
sourceOpts)
  where
    binaryOnly :: Parser (Maybe a)
binaryOnly = Maybe a -> Mod FlagFields (Maybe a) -> Parser (Maybe a)
forall a. a -> Mod FlagFields a -> Parser a
flag' Maybe a
forall a. Maybe a
Nothing (String -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"binary-only" Mod FlagFields (Maybe a)
-> Mod FlagFields (Maybe a) -> Mod FlagFields (Maybe a)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Do not use a source upgrade path")
    sourceOnly :: Parser (Maybe a)
sourceOnly = Maybe a -> Mod FlagFields (Maybe a) -> Parser (Maybe a)
forall a. a -> Mod FlagFields a -> Parser a
flag' Maybe a
forall a. Maybe a
Nothing (String -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"source-only" Mod FlagFields (Maybe a)
-> Mod FlagFields (Maybe a) -> Mod FlagFields (Maybe a)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Do not use a binary upgrade path")

    binaryOpts :: Parser BinaryOpts
binaryOpts = Maybe String
-> Bool
-> Maybe String
-> Maybe String
-> Maybe String
-> BinaryOpts
BinaryOpts
        (Maybe String
 -> Bool
 -> Maybe String
 -> Maybe String
 -> Maybe String
 -> BinaryOpts)
-> Parser (Maybe String)
-> Parser
     (Bool
      -> Maybe String -> Maybe String -> Maybe String -> BinaryOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
              ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"binary-platform"
             Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Platform type for archive to download"
             Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
showDefault))
        Parser
  (Bool
   -> Maybe String -> Maybe String -> Maybe String -> BinaryOpts)
-> Parser Bool
-> Parser
     (Maybe String -> Maybe String -> Maybe String -> BinaryOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
         (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"force-download" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
          String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Download the latest available stack executable")
        Parser (Maybe String -> Maybe String -> Maybe String -> BinaryOpts)
-> Parser (Maybe String)
-> Parser (Maybe String -> Maybe String -> BinaryOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
         (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"binary-version" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
          String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Download a specific stack version"))
        Parser (Maybe String -> Maybe String -> BinaryOpts)
-> Parser (Maybe String) -> Parser (Maybe String -> BinaryOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
         (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"github-org" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
          String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Github organization name"))
        Parser (Maybe String -> BinaryOpts)
-> Parser (Maybe String) -> Parser BinaryOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
         (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"github-repo" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
          String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Github repository name"))

    sourceOpts :: Parser SourceOpts
sourceOpts = Maybe (String, String) -> SourceOpts
SourceOpts
        (Maybe (String, String) -> SourceOpts)
-> Parser (Maybe (String, String)) -> Parser SourceOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Bool
fromGit String
repo String
branch -> if Bool
fromGit then (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
repo, String
branch) else Maybe (String, String)
forall a. Maybe a
Nothing)
                (Bool -> String -> String -> Maybe (String, String))
-> Parser Bool
-> Parser (String -> String -> Maybe (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch
                    ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"git"
                    Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Clone from Git instead of downloading from Hackage (more dangerous)" )
                Parser (String -> String -> Maybe (String, String))
-> Parser String -> Parser (String -> Maybe (String, String))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                    ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"git-repo"
                    Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Clone from specified git repository"
                    Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"https://github.com/commercialhaskell/stack"
                    Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
showDefault )
                Parser (String -> Maybe (String, String))
-> Parser String -> Parser (Maybe (String, String))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                    ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"git-branch"
                   Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Clone from this git branch"
                   Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"master"
                   Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
showDefault ))

data BinaryOpts = BinaryOpts
    { BinaryOpts -> Maybe String
_boPlatform :: !(Maybe String)
    , BinaryOpts -> Bool
_boForce :: !Bool
    -- ^ force a download, even if the downloaded version is older
    -- than what we are
    , BinaryOpts -> Maybe String
_boVersion :: !(Maybe String)
    -- ^ specific version to download
    , BinaryOpts -> Maybe String
_boGithubOrg :: !(Maybe String)
    , BinaryOpts -> Maybe String
_boGithubRepo :: !(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
showList :: [BinaryOpts] -> ShowS
$cshowList :: [BinaryOpts] -> ShowS
show :: BinaryOpts -> String
$cshow :: BinaryOpts -> String
showsPrec :: Int -> BinaryOpts -> ShowS
$cshowsPrec :: Int -> BinaryOpts -> ShowS
Show
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
showList :: [SourceOpts] -> ShowS
$cshowList :: [SourceOpts] -> ShowS
show :: SourceOpts -> String
$cshow :: SourceOpts -> String
showsPrec :: Int -> SourceOpts -> ShowS
$cshowsPrec :: Int -> SourceOpts -> ShowS
Show

data UpgradeOpts = UpgradeOpts
    { UpgradeOpts -> Maybe BinaryOpts
_uoBinary :: !(Maybe BinaryOpts)
    , UpgradeOpts -> Maybe SourceOpts
_uoSource :: !(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
showList :: [UpgradeOpts] -> ShowS
$cshowList :: [UpgradeOpts] -> ShowS
show :: UpgradeOpts -> String
$cshow :: UpgradeOpts -> String
showsPrec :: Int -> UpgradeOpts -> ShowS
$cshowsPrec :: Int -> UpgradeOpts -> ShowS
Show

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) -> String -> RIO Runner ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"You must allow either binary or source upgrade paths"
        (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 ()
prettyWarnL
               [ String -> StyleDoc
flow String
"Exception occured when trying to perform binary upgrade:"
               , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (SomeException -> String) -> SomeException -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show (SomeException -> StyleDoc) -> SomeException -> StyleDoc
forall a b. (a -> b) -> a -> b
$ SomeException
e
               , StyleDoc
line 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
bo = BinaryOpts -> RIO Runner ()
binaryUpgrade BinaryOpts
bo
    source :: SourceOpts -> RIO Runner ()
source SourceOpts
so = Maybe String -> SourceOpts -> RIO Runner ()
sourceUpgrade Maybe String
builtHash SourceOpts
so

binaryUpgrade :: BinaryOpts -> RIO Runner ()
binaryUpgrade :: BinaryOpts -> RIO Runner ()
binaryUpgrade (BinaryOpts Maybe String
mplatform Bool
force' 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 (m :: * -> *) a. Monad m => a -> m a
return [(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 (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe String -> Maybe String -> Maybe String -> m 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 ()
prettyErrorL ([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. a -> [a] -> [a]
:
                  [ StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Rerun with --force-download to force an upgrade"
                    | Bool -> Bool
not Bool
force]
                Bool -> RIO Config Bool
forall (m :: * -> *) a. Monad m => a -> m a
return 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)
                    ]
                Bool -> RIO Config Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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
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 -> Path Abs Dir
configLocalBin Config
config) Bool
True ((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)
                    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Non-success exit code from running newly downloaded executable"

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 (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
            [] -> String -> RIO Runner String
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> RIO Runner String) -> String -> RIO Runner String
forall a b. (a -> b) -> a -> b
$ String
"No commits found for branch " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
branch String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" on repo " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
repo
            String
x:[String]
_ -> String -> RIO Runner String
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> RIO Runner ()) -> String -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
                       String
"Information about the commit this version of stack was "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"built from is not available due to how it was built. "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Will continue by assuming an upgrade is needed "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"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 (m :: * -> *) a. Monad m => a -> m a
return 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_
                -- On Windows 10, an upstream issue with the `git clone` command
                -- means that command clears, but does not then restore, the
                -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals.
                -- The following hack re-enables the lost ANSI-capability.
                Bool -> RIO Runner () -> RIO Runner ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
                  RIO Runner (Maybe Bool) -> RIO Runner ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO Runner (Maybe Bool) -> RIO Runner ())
-> RIO Runner (Maybe Bool) -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe Bool) -> RIO Runner (Maybe Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> RIO Runner (Maybe Bool))
-> IO (Maybe Bool) -> RIO Runner (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stdout
                Maybe (Path Abs Dir) -> RIO Runner (Maybe (Path Abs Dir))
forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> String -> RIO Config PackageIdentifierRevision
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No stack found in package indices"
            Just PackageIdentifierRevision
version -> PackageIdentifierRevision -> RIO Config PackageIdentifierRevision
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 -> Version
mkVersion' Version
Paths.version
            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 (m :: * -> *) a. Monad m => a -> m a
return 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 -> String -> RIO Config (Maybe (Path Abs Dir))
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Latest version with no revision"
                  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 (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
          { globalResolver :: Maybe AbstractResolver
globalResolver = Maybe AbstractResolver
forall a. Maybe a
Nothing -- always use the resolver settings in the stack.yaml file
          , globalStackYaml :: StackYamlLoc
globalStackYaml = Path Abs File -> StackYamlLoc
SYLOverride (Path Abs File -> StackYamlLoc) -> Path Abs File -> StackYamlLoc
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
          }
        boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
          { boptsCLITargets :: [Text]
boptsCLITargets = [Text
"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 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
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 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
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