{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE TemplateHaskell #-}

module Stack.Upgrade

( upgrade

, UpgradeOpts

, upgradeOpts

) where

import Stack.Prelude hiding (force)

import qualified Data.HashMap.Strict as HashMap

import qualified Data.List

import qualified Data.Map as Map

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.Config

import Stack.Fetch

import Stack.PackageIndex

import Stack.PrettyPrint

import Stack.Setup

import Stack.Types.PackageIdentifier

import Stack.Types.PackageIndex

import Stack.Types.PackageName

import Stack.Types.Version

import Stack.Types.Config

import Stack.Types.Resolver

import System.Exit (ExitCode (ExitSuccess))

import System.Process (rawSystem, readProcess)

import System.Process.Run

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

-- ^ force a download, even if the downloaded version is older

-- than what we are

, _boVersion :: !(Maybe String)

-- ^ specific version to download

, _boGithubOrg :: !(Maybe String)

, _boGithubRepo :: !(Maybe String)

}

deriving Show

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

deriving Show

data UpgradeOpts = UpgradeOpts

{ _uoBinary :: !(Maybe BinaryOpts)

, _uoSource :: !(Maybe SourceOpts)

}

deriving Show

upgrade :: HasConfig env

=> ConfigMonoid

-> Maybe AbstractResolver

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

-> UpgradeOpts

-> RIO env ()

upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) =

case (mbo, 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.

(Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths"

(Just bo, Nothing) -> binary bo

(Nothing, Just so) -> source so

-- See #2977 - if --git or --git-repo is specified, do source upgrade.

(_, 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 gConfigMonoid mresolver builtHash so

binaryUpgrade :: HasConfig env => BinaryOpts -> RIO env ()

binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = 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 -- specifying a version implies we're forcing things

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:"

, display stackVersion <> ","

, flow "available download version:"

, display 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

-- Sanity check!

ec <- rawSystem (toFilePath tmpFile) ["--version"]

unless (ec == ExitSuccess)

$ throwString "Non-success exit code from running newly downloaded executable"

sourceUpgrade

:: HasConfig env

=> ConfigMonoid

-> Maybe AbstractResolver

-> Maybe String

-> SourceOpts

-> RIO env ()

sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =

withSystemTempDir "stack-upgrade" $ \tmp -> do

menv <- getMinimalEnvOverride

mdir <- case gitRepo of

Just (repo, branch) -> do

remote <- liftIO $ 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"

-- 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 = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch]

runCmd (Cmd (Just tmp) "git" menv args) Nothing

return $ Just $ tmp </> $(mkRelDir "stack")

Nothing -> do

updateAllIndices

PackageCache caches <- getPackageCaches

let versions

= filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it

$ maybe [] HashMap.keys

$ HashMap.lookup $(mkPackageName "stack") caches

when (null versions) (throwString "No stack found in package indices")

let version = Data.List.maximum versions

if version <= fromCabalVersion (mkVersion' Paths.version)

then do

prettyInfoS "Already at latest version, no upgrade required"

return Nothing

else do

let ident = PackageIdentifier $(mkPackageName "stack") version

paths <- unpackPackageIdents tmp Nothing

-- accept latest cabal revision

[PackageIdentifierRevision ident CFILatest]

case Map.lookup ident paths of

Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"

Just path -> return $ Just path

forM_ mdir $ \dir -> do

lc <- loadConfig

gConfigMonoid

mresolver

(SYLOverride $ dir </> $(mkRelFile "stack.yaml"))

bconfig <- liftIO $ lcLoadBuildConfig lc Nothing

envConfig1 <- runRIO bconfig $ setupEnv $ Just $

"Try rerunning with --install-ghc to install the correct GHC into " <>

T.pack (toFilePath (configLocalPrograms (view configL bconfig)))

runRIO (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $

build (const $ return ()) Nothing defaultBuildOptsCLI

{ boptsCLITargets = ["stack"]

}