{-# 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 Lens.Micro (set)
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 = UpgradeOpts
<$> (sourceOnly <|> optional binaryOpts)
<*> (binaryOnly <|> optional sourceOpts)
where
binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path")
sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path")
binaryOpts = BinaryOpts
<$> optional (strOption
( long "binary-platform"
<> help "Platform type for archive to download"
<> showDefault))
<*> switch
(long "force-download" <>
help "Download the latest available stack executable")
<*> optional (strOption
(long "binary-version" <>
help "Download a specific stack version"))
<*> optional (strOption
(long "github-org" <>
help "Github organization name"))
<*> optional (strOption
(long "github-repo" <>
help "Github repository name"))
sourceOpts = SourceOpts
<$> ((\fromGit repo branch -> if fromGit then Just (repo, branch) else Nothing)
<$> switch
( long "git"
<> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
<*> strOption
( long "git-repo"
<> help "Clone from specified git repository"
<> value "https://github.com/commercialhaskell/stack"
<> showDefault )
<*> strOption
( long "git-branch"
<> help "Clone from this git branch"
<> value "master"
<> showDefault ))
data BinaryOpts = BinaryOpts
{ _boPlatform :: !(Maybe String)
, _boForce :: !Bool
, _boVersion :: !(Maybe String)
, _boGithubOrg :: !(Maybe String)
, _boGithubRepo :: !(Maybe String)
}
deriving Show
newtype SourceOpts = SourceOpts (Maybe (String, String))
deriving Show
data UpgradeOpts = UpgradeOpts
{ _uoBinary :: !(Maybe BinaryOpts)
, _uoSource :: !(Maybe SourceOpts)
}
deriving Show
upgrade :: Maybe String
-> UpgradeOpts
-> RIO Runner ()
upgrade builtHash (UpgradeOpts mbo mso) =
case (mbo, mso) of
(Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths"
(Just bo, Nothing) -> binary bo
(Nothing, Just so) -> source so
(_, Just so@(SourceOpts (Just _))) -> source so
(Just bo, Just so) -> binary bo `catchAny` \e -> do
prettyWarnL
[ flow "Exception occured when trying to perform binary upgrade:"
, fromString . show $ e
, line <> flow "Falling back to source upgrade"
]
source so
where
binary bo = binaryUpgrade bo
source so = sourceUpgrade builtHash so
binaryUpgrade :: BinaryOpts -> RIO Runner ()
binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = withConfig NoReexec $ do
platforms0 <-
case mplatform of
Nothing -> preferredPlatforms
Just p -> return [("windows" `T.isInfixOf` T.pack p, p)]
archiveInfo <- downloadStackReleaseInfo morg mrepo mver
let mdownloadVersion = getDownloadVersion archiveInfo
force =
case mver of
Nothing -> force'
Just _ -> True
isNewer <-
case mdownloadVersion of
Nothing -> do
prettyErrorL $
flow "Unable to determine upstream version from Github metadata"
:
[ line <> flow "Rerun with --force-download to force an upgrade"
| not force]
return False
Just downloadVersion -> do
prettyInfoL
[ flow "Current Stack version:"
, fromString (versionString stackVersion) <> ","
, flow "available download version:"
, fromString (versionString downloadVersion)
]
return $ downloadVersion > stackVersion
toUpgrade <- case (force, isNewer) of
(False, False) -> do
prettyInfoS "Skipping binary upgrade, you are already running the most recent version"
return False
(True, False) -> do
prettyInfoS "Forcing binary upgrade"
return True
(_, True) -> do
prettyInfoS "Newer version detected, downloading"
return True
when toUpgrade $ do
config <- view configL
downloadStackExe platforms0 archiveInfo (configLocalBin config) True $ \tmpFile -> do
ec <- rawSystem (toFilePath tmpFile) ["--version"]
unless (ec == ExitSuccess)
$ throwString "Non-success exit code from running newly downloaded executable"
sourceUpgrade
:: Maybe String
-> SourceOpts
-> RIO Runner ()
sourceUpgrade builtHash (SourceOpts gitRepo) =
withSystemTempDir "stack-upgrade" $ \tmp -> do
mdir <- case gitRepo of
Just (repo, branch) -> do
remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] []
latestCommit <-
case words remote of
[] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo
x:_ -> return x
when (isNothing builtHash) $
prettyWarnS $
"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 builtHash == Just latestCommit
then do
prettyInfoS "Already up-to-date, no upgrade required"
return Nothing
else do
prettyInfoS "Cloning stack"
let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch]
withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_
when osIsWindows $
void $ liftIO $ hSupportsANSIWithoutEmulation stdout
return $ Just $ tmp </> relDirStackProgName
Nothing -> withConfig NoReexec $ do
void $ updateHackageIndex
$ Just "Updating index to make sure we find the latest Stack version"
mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions
(PackageIdentifierRevision _ version _) <-
case mversion of
Nothing -> throwString "No stack found in package indices"
Just version -> pure version
if version <= mkVersion' Paths.version
then do
prettyInfoS "Already at latest version, no upgrade required"
return Nothing
else do
suffix <- parseRelDir $ "stack-" ++ versionString version
let dir = tmp </> suffix
mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version
case mrev of
Nothing -> throwString "Latest version with no revision"
Just (_rev, cfKey, treeKey) -> do
let ident = PackageIdentifier "stack" version
unpackPackageLocation dir $ PLIHackage ident cfKey treeKey
pure $ Just dir
let modifyGO dir go = go
{ globalResolver = Nothing
, globalStackYaml = SYLOverride $ dir </> stackDotYaml
}
boptsCLI = defaultBuildOptsCLI
{ boptsCLITargets = ["stack"]
}
forM_ mdir $ \dir ->
local (over globalOptsL (modifyGO dir)) $
withConfig NoReexec $ withEnvConfig AllowNoTargets boptsCLI $
local (set (buildOptsL.buildOptsInstallExesL) True) $
build Nothing