1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE OverloadedStrings #-} 6module Stack.Upgrade 7 ( upgrade 8 , UpgradeOpts 9 , upgradeOpts 10 ) where 11 12import Stack.Prelude hiding (force, Display (..)) 13import qualified Data.Text as T 14import Distribution.Version (mkVersion') 15import Options.Applicative 16import Path 17import qualified Paths_stack as Paths 18import Stack.Build 19import Stack.Build.Target (NeedTargets(..)) 20import Stack.Constants 21import Stack.Runners 22import Stack.Setup 23import Stack.Types.Config 24import System.Console.ANSI (hSupportsANSIWithoutEmulation) 25import System.Process (rawSystem, readProcess) 26import RIO.PrettyPrint 27import RIO.Process 28 29upgradeOpts :: Parser UpgradeOpts 30upgradeOpts = UpgradeOpts 31 <$> (sourceOnly <|> optional binaryOpts) 32 <*> (binaryOnly <|> optional sourceOpts) 33 where 34 binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path") 35 sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path") 36 37 binaryOpts = BinaryOpts 38 <$> optional (strOption 39 ( long "binary-platform" 40 <> help "Platform type for archive to download" 41 <> showDefault)) 42 <*> switch 43 (long "force-download" <> 44 help "Download the latest available stack executable") 45 <*> optional (strOption 46 (long "binary-version" <> 47 help "Download a specific stack version")) 48 <*> optional (strOption 49 (long "github-org" <> 50 help "Github organization name")) 51 <*> optional (strOption 52 (long "github-repo" <> 53 help "Github repository name")) 54 55 sourceOpts = SourceOpts 56 <$> ((\fromGit repo branch -> if fromGit then Just (repo, branch) else Nothing) 57 <$> switch 58 ( long "git" 59 <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) 60 <*> strOption 61 ( long "git-repo" 62 <> help "Clone from specified git repository" 63 <> value "https://github.com/commercialhaskell/stack" 64 <> showDefault ) 65 <*> strOption 66 ( long "git-branch" 67 <> help "Clone from this git branch" 68 <> value "master" 69 <> showDefault )) 70 71data BinaryOpts = BinaryOpts 72 { _boPlatform :: !(Maybe String) 73 , _boForce :: !Bool 74 -- ^ force a download, even if the downloaded version is older 75 -- than what we are 76 , _boVersion :: !(Maybe String) 77 -- ^ specific version to download 78 , _boGithubOrg :: !(Maybe String) 79 , _boGithubRepo :: !(Maybe String) 80 } 81 deriving Show 82newtype SourceOpts = SourceOpts (Maybe (String, String)) -- repo and branch 83 deriving Show 84 85data UpgradeOpts = UpgradeOpts 86 { _uoBinary :: !(Maybe BinaryOpts) 87 , _uoSource :: !(Maybe SourceOpts) 88 } 89 deriving Show 90 91upgrade :: Maybe String -- ^ git hash at time of building, if known 92 -> UpgradeOpts 93 -> RIO Runner () 94upgrade builtHash (UpgradeOpts mbo mso) = 95 case (mbo, mso) of 96 -- FIXME It would be far nicer to capture this case in the 97 -- options parser itself so we get better error messages, but 98 -- I can't think of a way to make it happen. 99 (Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths" 100 (Just bo, Nothing) -> binary bo 101 (Nothing, Just so) -> source so 102 -- See #2977 - if --git or --git-repo is specified, do source upgrade. 103 (_, Just so@(SourceOpts (Just _))) -> source so 104 (Just bo, Just so) -> binary bo `catchAny` \e -> do 105 prettyWarnL 106 [ flow "Exception occured when trying to perform binary upgrade:" 107 , fromString . show $ e 108 , line <> flow "Falling back to source upgrade" 109 ] 110 111 source so 112 where 113 binary bo = binaryUpgrade bo 114 source so = sourceUpgrade builtHash so 115 116binaryUpgrade :: BinaryOpts -> RIO Runner () 117binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = withConfig NoReexec $ do 118 platforms0 <- 119 case mplatform of 120 Nothing -> preferredPlatforms 121 Just p -> return [("windows" `T.isInfixOf` T.pack p, p)] 122 archiveInfo <- downloadStackReleaseInfo morg mrepo mver 123 124 let mdownloadVersion = getDownloadVersion archiveInfo 125 force = 126 case mver of 127 Nothing -> force' 128 Just _ -> True -- specifying a version implies we're forcing things 129 isNewer <- 130 case mdownloadVersion of 131 Nothing -> do 132 prettyErrorL $ 133 flow "Unable to determine upstream version from Github metadata" 134 : 135 [ line <> flow "Rerun with --force-download to force an upgrade" 136 | not force] 137 return False 138 Just downloadVersion -> do 139 prettyInfoL 140 [ flow "Current Stack version:" 141 , fromString (versionString stackVersion) <> "," 142 , flow "available download version:" 143 , fromString (versionString downloadVersion) 144 ] 145 return $ downloadVersion > stackVersion 146 147 toUpgrade <- case (force, isNewer) of 148 (False, False) -> do 149 prettyInfoS "Skipping binary upgrade, you are already running the most recent version" 150 return False 151 (True, False) -> do 152 prettyInfoS "Forcing binary upgrade" 153 return True 154 (_, True) -> do 155 prettyInfoS "Newer version detected, downloading" 156 return True 157 when toUpgrade $ do 158 config <- view configL 159 downloadStackExe platforms0 archiveInfo (configLocalBin config) True $ \tmpFile -> do 160 -- Sanity check! 161 ec <- rawSystem (toFilePath tmpFile) ["--version"] 162 163 unless (ec == ExitSuccess) 164 $ throwString "Non-success exit code from running newly downloaded executable" 165 166sourceUpgrade 167 :: Maybe String 168 -> SourceOpts 169 -> RIO Runner () 170sourceUpgrade builtHash (SourceOpts gitRepo) = 171 withSystemTempDir "stack-upgrade" $ \tmp -> do 172 mdir <- case gitRepo of 173 Just (repo, branch) -> do 174 remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] [] 175 latestCommit <- 176 case words remote of 177 [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo 178 x:_ -> return x 179 when (isNothing builtHash) $ 180 prettyWarnS $ 181 "Information about the commit this version of stack was " 182 <> "built from is not available due to how it was built. " 183 <> "Will continue by assuming an upgrade is needed " 184 <> "because we have no information to the contrary." 185 if builtHash == Just latestCommit 186 then do 187 prettyInfoS "Already up-to-date, no upgrade required" 188 return Nothing 189 else do 190 prettyInfoS "Cloning stack" 191 -- NOTE: "--recursive" was added after v1.0.0 (and before the 192 -- next release). This means that we can't use submodules in 193 -- the stack repo until we're comfortable with "stack upgrade 194 -- --git" not working for earlier versions. 195 let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch] 196 withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_ 197 -- On Windows 10, an upstream issue with the `git clone` command 198 -- means that command clears, but does not then restore, the 199 -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. 200 -- The following hack re-enables the lost ANSI-capability. 201 when osIsWindows $ 202 void $ liftIO $ hSupportsANSIWithoutEmulation stdout 203 return $ Just $ tmp </> relDirStackProgName 204 -- We need to access the Pantry database to find out about the 205 -- latest Stack available on Hackage. We first use a standard 206 -- Config to do this, and once we have the source load up the 207 -- stack.yaml from inside that source. 208 Nothing -> withConfig NoReexec $ do 209 void $ updateHackageIndex 210 $ Just "Updating index to make sure we find the latest Stack version" 211 mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions 212 (PackageIdentifierRevision _ version _) <- 213 case mversion of 214 Nothing -> throwString "No stack found in package indices" 215 Just version -> pure version 216 217 if version <= mkVersion' Paths.version 218 then do 219 prettyInfoS "Already at latest version, no upgrade required" 220 return Nothing 221 else do 222 suffix <- parseRelDir $ "stack-" ++ versionString version 223 let dir = tmp </> suffix 224 mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version 225 case mrev of 226 Nothing -> throwString "Latest version with no revision" 227 Just (_rev, cfKey, treeKey) -> do 228 let ident = PackageIdentifier "stack" version 229 unpackPackageLocation dir $ PLIHackage ident cfKey treeKey 230 pure $ Just dir 231 232 let modifyGO dir go = go 233 { globalResolver = Nothing -- always use the resolver settings in the stack.yaml file 234 , globalStackYaml = SYLOverride $ dir </> stackDotYaml 235 } 236 boptsCLI = defaultBuildOptsCLI 237 { boptsCLITargets = ["stack"] 238 } 239 forM_ mdir $ \dir -> 240 local (over globalOptsL (modifyGO dir)) $ 241 withConfig NoReexec $ withEnvConfig AllowNoTargets boptsCLI $ 242 local (set (buildOptsL.buildOptsInstallExesL) True) $ 243 build Nothing 244