1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE DataKinds #-} 4{-# LANGUAGE DeriveFunctor #-} 5{-# LANGUAGE FlexibleContexts #-} 6{-# LANGUAGE LambdaCase #-} 7{-# LANGUAGE OverloadedStrings #-} 8{-# LANGUAGE PackageImports #-} 9{-# LANGUAGE ScopedTypeVariables #-} 10{-# LANGUAGE ViewPatterns #-} 11{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE MultiWayIf #-} 13 14module Stack.Setup 15 ( setupEnv 16 , ensureCompilerAndMsys 17 , ensureDockerStackExe 18 , SetupOpts (..) 19 , defaultSetupInfoYaml 20 , withNewLocalBuildTargets 21 22 -- * Stack binary download 23 , StackReleaseInfo 24 , getDownloadVersion 25 , stackVersion 26 , preferredPlatforms 27 , downloadStackReleaseInfo 28 , downloadStackExe 29 ) where 30 31import qualified Codec.Archive.Tar as Tar 32import Conduit 33import Control.Applicative (empty) 34import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..)) 35import Pantry.Internal.AesonExtended 36import qualified Data.ByteString as S 37import qualified Data.ByteString.Lazy as LBS 38import qualified Data.Conduit.Binary as CB 39import Data.Conduit.Lazy (lazyConsume) 40import qualified Data.Conduit.List as CL 41import Data.Conduit.Process.Typed (createSource) 42import Data.Conduit.Zlib (ungzip) 43import Data.Foldable (maximumBy) 44import qualified Data.HashMap.Strict as HashMap 45import Data.List hiding (concat, elem, maximumBy, any) 46import qualified Data.Map as Map 47import qualified Data.Set as Set 48import qualified Data.Text as T 49import qualified Data.Text.Encoding as T 50import qualified Data.Text.Encoding.Error as T 51import qualified Data.Yaml as Yaml 52import Distribution.System (OS, Arch (..), Platform (..)) 53import qualified Distribution.System as Cabal 54import Distribution.Text (simpleParse) 55import Distribution.Types.PackageName (mkPackageName) 56import Distribution.Version (mkVersion) 57import Network.HTTP.Client (redirectCount) 58import Network.HTTP.StackClient (CheckHexDigest (..), HashCheck (..), 59 getResponseBody, getResponseStatusCode, httpLbs, httpJSON, 60 mkDownloadRequest, parseRequest, parseUrlThrow, setGithubHeaders, 61 setHashChecks, setLengthCheck, verifiedDownloadWithProgress, withResponse, 62 setRequestMethod) 63import Network.HTTP.Simple (getResponseHeader) 64import Path hiding (fileExtension) 65import Path.CheckInstall (warnInstallSearchPathIssues) 66import Path.Extended (fileExtension) 67import Path.Extra (toFilePathNoTrailingSep) 68import Path.IO hiding (findExecutable, withSystemTempDir) 69import qualified Pantry 70import qualified RIO 71import RIO.List 72import RIO.PrettyPrint 73import RIO.Process 74import Stack.Build.Haddock (shouldHaddockDeps) 75import Stack.Build.Source (loadSourceMap, hashSourceMapData) 76import Stack.Build.Target (NeedTargets(..), parseTargets) 77import Stack.Constants 78import Stack.Constants.Config (distRelativeDir) 79import Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) 80import Stack.Prelude hiding (Display (..)) 81import Stack.SourceMap 82import Stack.Setup.Installed 83import Stack.Storage.User (loadCompilerPaths, saveCompilerPaths) 84import Stack.Types.Build 85import Stack.Types.Compiler 86import Stack.Types.CompilerBuild 87import Stack.Types.Config 88import Stack.Types.Docker 89import Stack.Types.SourceMap 90import Stack.Types.Version 91import qualified System.Directory as D 92import System.Environment (getExecutablePath, lookupEnv) 93import System.IO.Error (isPermissionError) 94import System.FilePath (searchPathSeparator) 95import qualified System.FilePath as FP 96import System.Permissions (setFileExecutable) 97import System.Uname (getRelease) 98import Data.List.Split (splitOn) 99 100-- | Default location of the stack-setup.yaml file 101defaultSetupInfoYaml :: String 102defaultSetupInfoYaml = 103 "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml" 104 105data SetupOpts = SetupOpts 106 { soptsInstallIfMissing :: !Bool 107 , soptsUseSystem :: !Bool 108 -- ^ Should we use a system compiler installation, if available? 109 , soptsWantedCompiler :: !WantedCompiler 110 , soptsCompilerCheck :: !VersionCheck 111 , soptsStackYaml :: !(Maybe (Path Abs File)) 112 -- ^ If we got the desired GHC version from that file 113 , soptsForceReinstall :: !Bool 114 , soptsSanityCheck :: !Bool 115 -- ^ Run a sanity check on the selected GHC 116 , soptsSkipGhcCheck :: !Bool 117 -- ^ Don't check for a compatible GHC version/architecture 118 , soptsSkipMsys :: !Bool 119 -- ^ Do not use a custom msys installation on Windows 120 , soptsResolveMissingGHC :: !(Maybe Text) 121 -- ^ Message shown to user for how to resolve the missing GHC 122 , soptsGHCBindistURL :: !(Maybe String) 123 -- ^ Alternate GHC binary distribution (requires custom GHCVariant) 124 } 125 deriving Show 126data SetupException = UnsupportedSetupCombo OS Arch 127 | MissingDependencies [String] 128 | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler) 129 | UnknownOSKey Text 130 | GHCSanityCheckCompileFailed SomeException (Path Abs File) 131 | WantedMustBeGHC 132 | RequireCustomGHCVariant 133 | ProblemWhileDecompressing (Path Abs File) 134 | SetupInfoMissingSevenz 135 | DockerStackExeNotFound Version Text 136 | UnsupportedSetupConfiguration 137 | InvalidGhcAt (Path Abs File) SomeException 138 deriving Typeable 139instance Exception SetupException 140instance Show SetupException where 141 show (UnsupportedSetupCombo os arch) = concat 142 [ "I don't know how to install GHC for " 143 , show (os, arch) 144 , ", please install manually" 145 ] 146 show (MissingDependencies tools) = 147 "The following executables are missing and must be installed: " ++ 148 intercalate ", " tools 149 show (UnknownCompilerVersion oskeys wanted known) = concat 150 [ "No setup information found for " 151 , T.unpack $ utf8BuilderToText $ RIO.display wanted 152 , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '" 153 , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys)) 154 , "'.\nSupported versions: " 155 , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known))) 156 ] 157 show (UnknownOSKey oskey) = 158 "Unable to find installation URLs for OS key: " ++ 159 T.unpack oskey 160 show (GHCSanityCheckCompileFailed e ghc) = concat 161 [ "The GHC located at " 162 , toFilePath ghc 163 , " failed to compile a sanity check. Please see:\n\n" 164 , " http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n" 165 , "for more information. Exception was:\n" 166 , show e 167 ] 168 show WantedMustBeGHC = 169 "The wanted compiler must be GHC" 170 show RequireCustomGHCVariant = 171 "A custom --ghc-variant must be specified to use --ghc-bindist" 172 show (ProblemWhileDecompressing archive) = 173 "Problem while decompressing " ++ toFilePath archive 174 show SetupInfoMissingSevenz = 175 "SetupInfo missing Sevenz EXE/DLL" 176 show (DockerStackExeNotFound stackVersion' osKey) = concat 177 [ stackProgName 178 , "-" 179 , versionString stackVersion' 180 , " executable not found for " 181 , T.unpack osKey 182 , "\nUse the '" 183 , T.unpack dockerStackExeArgName 184 , "' option to specify a location"] 185 show UnsupportedSetupConfiguration = 186 "I don't know how to install GHC on your system configuration, please install manually" 187 show (InvalidGhcAt compiler e) = 188 "Found an invalid compiler at " ++ show (toFilePath compiler) ++ ": " ++ displayException e 189 190-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too 191setupEnv :: NeedTargets 192 -> BuildOptsCLI 193 -> Maybe Text -- ^ Message to give user when necessary GHC is not available 194 -> RIO BuildConfig EnvConfig 195setupEnv needTargets boptsCLI mResolveMissingGHC = do 196 config <- view configL 197 bc <- view buildConfigL 198 let stackYaml = bcStackYaml bc 199 platform <- view platformL 200 wcVersion <- view wantedCompilerVersionL 201 wanted <- view wantedCompilerVersionL 202 actual <- either throwIO pure $ wantedToActual wanted 203 let wc = actual^.whichCompilerL 204 let sopts = SetupOpts 205 { soptsInstallIfMissing = configInstallGHC config 206 , soptsUseSystem = configSystemGHC config 207 , soptsWantedCompiler = wcVersion 208 , soptsCompilerCheck = configCompilerCheck config 209 , soptsStackYaml = Just stackYaml 210 , soptsForceReinstall = False 211 , soptsSanityCheck = False 212 , soptsSkipGhcCheck = configSkipGHCCheck config 213 , soptsSkipMsys = configSkipMsys config 214 , soptsResolveMissingGHC = mResolveMissingGHC 215 , soptsGHCBindistURL = Nothing 216 } 217 218 (compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts 219 let compilerVer = cpCompilerVersion compilerPaths 220 221 -- Modify the initial environment to include the GHC path, if a local GHC 222 -- is being used 223 menv0 <- view processContextL 224 env <- either throwM (return . removeHaskellEnvVars) 225 $ augmentPathMap 226 (map toFilePath $ edBins ghcBin) 227 (view envVarsL menv0) 228 menv <- mkProcessContext env 229 230 logDebug "Resolving package entries" 231 232 (sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do 233 smActual <- actualFromGhc (bcSMWanted bc) compilerVer 234 let actualPkgs = Map.keysSet (smaDeps smActual) <> 235 Map.keysSet (smaProject smActual) 236 prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs } 237 haddockDeps = shouldHaddockDeps (configBuild config) 238 targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual 239 sourceMap <- loadSourceMap targets boptsCLI smActual 240 sourceMapHash <- hashSourceMapData boptsCLI sourceMap 241 pure (sourceMap, sourceMapHash) 242 243 let envConfig0 = EnvConfig 244 { envConfigBuildConfig = bc 245 , envConfigBuildOptsCLI = boptsCLI 246 , envConfigSourceMap = sourceMap 247 , envConfigSourceMapHash = sourceMapHash 248 , envConfigCompilerPaths = compilerPaths 249 } 250 251 -- extra installation bin directories 252 mkDirs <- runRIO envConfig0 extraBinDirs 253 let mpath = Map.lookup "PATH" env 254 depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath 255 localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath 256 257 deps <- runRIO envConfig0 packageDatabaseDeps 258 runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps 259 localdb <- runRIO envConfig0 packageDatabaseLocal 260 runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) localdb 261 extras <- runReaderT packageDatabaseExtra envConfig0 262 let mkGPP locals = mkGhcPackagePath locals localdb deps extras $ cpGlobalDB compilerPaths 263 264 distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath 265 266 executablePath <- liftIO getExecutablePath 267 268 utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer 269 270 mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS" 271 272 envRef <- liftIO $ newIORef Map.empty 273 let getProcessContext' es = do 274 m <- readIORef envRef 275 case Map.lookup es m of 276 Just eo -> return eo 277 Nothing -> do 278 eo <- mkProcessContext 279 $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath) 280 $ (if esIncludeGhcPackagePath es 281 then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es)) 282 else id) 283 284 $ (if esStackExe es 285 then Map.insert "STACK_EXE" (T.pack executablePath) 286 else id) 287 288 $ (if esLocaleUtf8 es 289 then Map.union utf8EnvVars 290 else id) 291 292 $ case (soptsSkipMsys sopts, platform) of 293 (False, Platform Cabal.I386 Cabal.Windows) 294 -> Map.insert "MSYSTEM" "MINGW32" 295 (False, Platform Cabal.X86_64 Cabal.Windows) 296 -> Map.insert "MSYSTEM" "MINGW64" 297 _ -> id 298 299 -- See https://github.com/commercialhaskell/stack/issues/3444 300 $ case (esKeepGhcRts es, mGhcRtsEnvVar) of 301 (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts) 302 _ -> id 303 304 -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70 305 $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps) 306 $ Map.insert "HASKELL_PACKAGE_SANDBOXES" 307 (T.pack $ if esIncludeLocals es 308 then intercalate [searchPathSeparator] 309 [ toFilePathNoTrailingSep localdb 310 , toFilePathNoTrailingSep deps 311 , "" 312 ] 313 else intercalate [searchPathSeparator] 314 [ toFilePathNoTrailingSep deps 315 , "" 316 ]) 317 $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) 318 319 -- Make sure that any .ghc.environment files 320 -- are ignored, since we're settting up our 321 -- own package databases. See 322 -- https://github.com/commercialhaskell/stack/issues/4706 323 $ (case cpCompilerVersion compilerPaths of 324 ACGhc version | version >= mkVersion [8, 4, 4] -> 325 Map.insert "GHC_ENVIRONMENT" "-" 326 _ -> id) 327 328 env 329 330 () <- atomicModifyIORef envRef $ \m' -> 331 (Map.insert es eo m', ()) 332 return eo 333 334 envOverride <- liftIO $ getProcessContext' minimalEnvSettings 335 return EnvConfig 336 { envConfigBuildConfig = bc 337 { bcConfig = addIncludeLib ghcBin 338 $ set processContextL envOverride 339 (view configL bc) 340 { configProcessContextSettings = getProcessContext' 341 } 342 } 343 , envConfigBuildOptsCLI = boptsCLI 344 , envConfigSourceMap = sourceMap 345 , envConfigSourceMapHash = sourceMapHash 346 , envConfigCompilerPaths = compilerPaths 347 } 348 349-- | A modified env which we know has an installed compiler on the PATH. 350data WithGHC env = WithGHC !CompilerPaths !env 351 352insideL :: Lens' (WithGHC env) env 353insideL = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp) 354 355instance HasLogFunc env => HasLogFunc (WithGHC env) where 356 logFuncL = insideL.logFuncL 357instance HasRunner env => HasRunner (WithGHC env) where 358 runnerL = insideL.runnerL 359instance HasProcessContext env => HasProcessContext (WithGHC env) where 360 processContextL = insideL.processContextL 361instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where 362 stylesUpdateL = insideL.stylesUpdateL 363instance HasTerm env => HasTerm (WithGHC env) where 364 useColorL = insideL.useColorL 365 termWidthL = insideL.termWidthL 366instance HasPantryConfig env => HasPantryConfig (WithGHC env) where 367 pantryConfigL = insideL.pantryConfigL 368instance HasConfig env => HasPlatform (WithGHC env) 369instance HasConfig env => HasGHCVariant (WithGHC env) 370instance HasConfig env => HasConfig (WithGHC env) where 371 configL = insideL.configL 372instance HasBuildConfig env => HasBuildConfig (WithGHC env) where 373 buildConfigL = insideL.buildConfigL 374instance HasCompiler (WithGHC env) where 375 compilerPathsL = to (\(WithGHC cp _) -> cp) 376 377-- | Set up a modified environment which includes the modified PATH 378-- that GHC can be found on. This is needed for looking up global 379-- package information and ghc fingerprint (result from 'ghc --info'). 380runWithGHC :: HasConfig env => ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a 381runWithGHC pc cp inner = do 382 env <- ask 383 let envg 384 = WithGHC cp $ 385 set envOverrideSettingsL (\_ -> return pc) $ 386 set processContextL pc env 387 runRIO envg inner 388 389-- | special helper for GHCJS which needs an updated source map 390-- only project dependencies should get included otherwise source map hash will 391-- get changed and EnvConfig will become inconsistent 392rebuildEnv :: EnvConfig 393 -> NeedTargets 394 -> Bool 395 -> BuildOptsCLI 396 -> RIO env EnvConfig 397rebuildEnv envConfig needTargets haddockDeps boptsCLI = do 398 let bc = envConfigBuildConfig envConfig 399 cp = envConfigCompilerPaths envConfig 400 compilerVer = smCompiler $ envConfigSourceMap envConfig 401 runRIO (WithGHC cp bc) $ do 402 smActual <- actualFromGhc (bcSMWanted bc) compilerVer 403 let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) 404 prunedActual = smActual { 405 smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs 406 } 407 targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual 408 sourceMap <- loadSourceMap targets boptsCLI smActual 409 return $ 410 envConfig 411 {envConfigSourceMap = sourceMap, envConfigBuildOptsCLI = boptsCLI} 412 413-- | Some commands (script, ghci and exec) set targets dynamically 414-- see also the note about only local targets for rebuildEnv 415withNewLocalBuildTargets :: HasEnvConfig env => [Text] -> RIO env a -> RIO env a 416withNewLocalBuildTargets targets f = do 417 envConfig <- view $ envConfigL 418 haddockDeps <- view $ configL.to configBuild.to shouldHaddockDeps 419 let boptsCLI = envConfigBuildOptsCLI envConfig 420 envConfig' <- rebuildEnv envConfig NeedTargets haddockDeps $ 421 boptsCLI {boptsCLITargets = targets} 422 local (set envConfigL envConfig') f 423 424-- | Add the include and lib paths to the given Config 425addIncludeLib :: ExtraDirs -> Config -> Config 426addIncludeLib (ExtraDirs _bins includes libs) config = config 427 { configExtraIncludeDirs = 428 configExtraIncludeDirs config ++ 429 map toFilePathNoTrailingSep includes 430 , configExtraLibDirs = 431 configExtraLibDirs config ++ 432 map toFilePathNoTrailingSep libs 433 } 434 435-- | Ensure both the compiler and the msys toolchain are installed and 436-- provide the PATHs to add if necessary 437ensureCompilerAndMsys 438 :: (HasBuildConfig env, HasGHCVariant env) 439 => SetupOpts 440 -> RIO env (CompilerPaths, ExtraDirs) 441ensureCompilerAndMsys sopts = do 442 actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts 443 didWarn <- warnUnsupportedCompiler $ getGhcVersion actual 444 445 getSetupInfo' <- memoizeRef getSetupInfo 446 (cp, ghcPaths) <- ensureCompiler sopts getSetupInfo' 447 448 warnUnsupportedCompilerCabal cp didWarn 449 450 mmsys2Tool <- ensureMsys sopts getSetupInfo' 451 paths <- 452 case mmsys2Tool of 453 Nothing -> pure ghcPaths 454 Just msys2Tool -> do 455 msys2Paths <- extraDirs msys2Tool 456 pure $ ghcPaths <> msys2Paths 457 pure (cp, paths) 458 459-- | See <https://github.com/commercialhaskell/stack/issues/4246> 460warnUnsupportedCompiler :: HasLogFunc env => Version -> RIO env Bool 461warnUnsupportedCompiler ghcVersion = do 462 if 463 | ghcVersion < mkVersion [7, 8] -> do 464 logWarn $ 465 "Stack will almost certainly fail with GHC below version 7.8, requested " <> 466 fromString (versionString ghcVersion) 467 logWarn "Valiantly attempting to run anyway, but I know this is doomed" 468 logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" 469 logWarn "" 470 pure True 471 | ghcVersion >= mkVersion [9, 1] -> do 472 logWarn $ 473 "Stack has not been tested with GHC versions above 9.0, and using " <> 474 fromString (versionString ghcVersion) <> 475 ", this may fail" 476 pure True 477 | otherwise -> do 478 logDebug "Asking for a supported GHC version" 479 pure False 480 481-- | See <https://github.com/commercialhaskell/stack/issues/4246> 482warnUnsupportedCompilerCabal 483 :: HasLogFunc env 484 => CompilerPaths 485 -> Bool -- ^ already warned about GHC? 486 -> RIO env () 487warnUnsupportedCompilerCabal cp didWarn = do 488 unless didWarn $ void $ warnUnsupportedCompiler $ getGhcVersion $ cpCompilerVersion cp 489 let cabalVersion = cpCabalVersion cp 490 491 if 492 | cabalVersion < mkVersion [1, 19, 2] -> do 493 logWarn $ "Stack no longer supports Cabal versions below 1.19.2," 494 logWarn $ "but version " <> fromString (versionString cabalVersion) <> " was found." 495 logWarn "This invocation will most likely fail." 496 logWarn "To fix this, either use an older version of Stack or a newer resolver" 497 logWarn "Acceptable resolvers: lts-3.0/nightly-2015-05-05 or later" 498 | cabalVersion >= mkVersion [3, 5] -> 499 logWarn $ 500 "Stack has not been tested with Cabal versions above 3.4, but version " <> 501 fromString (versionString cabalVersion) <> 502 " was found, this may fail" 503 | otherwise -> pure () 504 505-- | Ensure that the msys toolchain is installed if necessary and 506-- provide the PATHs to add if necessary 507ensureMsys 508 :: HasBuildConfig env 509 => SetupOpts 510 -> Memoized SetupInfo 511 -> RIO env (Maybe Tool) 512ensureMsys sopts getSetupInfo' = do 513 platform <- view platformL 514 localPrograms <- view $ configL.to configLocalPrograms 515 installed <- listInstalled localPrograms 516 517 case platform of 518 Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> 519 case getInstalledTool installed (mkPackageName "msys2") (const True) of 520 Just tool -> return (Just tool) 521 Nothing 522 | soptsInstallIfMissing sopts -> do 523 si <- runMemoized getSetupInfo' 524 osKey <- getOSKey platform 525 config <- view configL 526 VersionedDownloadInfo version info <- 527 case Map.lookup osKey $ siMsys2 si of 528 Just x -> return x 529 Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey 530 let tool = Tool (PackageIdentifier (mkPackageName "msys2") version) 531 Just <$> downloadAndInstallTool (configLocalPrograms config) info tool (installMsys2Windows si) 532 | otherwise -> do 533 logWarn "Continuing despite missing tool: msys2" 534 return Nothing 535 _ -> return Nothing 536 537installGhcBindist 538 :: HasBuildConfig env 539 => SetupOpts 540 -> Memoized SetupInfo 541 -> [Tool] 542 -> RIO env (Tool, CompilerBuild) 543installGhcBindist sopts getSetupInfo' installed = do 544 Platform expectedArch _ <- view platformL 545 let wanted = soptsWantedCompiler sopts 546 isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) 547 config <- view configL 548 ghcVariant <- view ghcVariantL 549 wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted 550 possibleCompilers <- 551 case wc of 552 Ghc -> do 553 ghcBuilds <- getGhcBuilds 554 forM ghcBuilds $ \ghcBuild -> do 555 ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) 556 return (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild) 557 let existingCompilers = concatMap 558 (\(installedCompiler, compilerBuild) -> 559 case (installedCompiler, soptsForceReinstall sopts) of 560 (Just tool, False) -> [(tool, compilerBuild)] 561 _ -> []) 562 possibleCompilers 563 logDebug $ 564 "Found already installed GHC builds: " <> 565 mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers)) 566 case existingCompilers of 567 (tool, build_):_ -> return (tool, build_) 568 [] 569 | soptsInstallIfMissing sopts -> do 570 si <- runMemoized getSetupInfo' 571 downloadAndInstallPossibleCompilers 572 (map snd possibleCompilers) 573 si 574 (soptsWantedCompiler sopts) 575 (soptsCompilerCheck sopts) 576 (soptsGHCBindistURL sopts) 577 | otherwise -> do 578 let suggestion = fromMaybe 579 (mconcat 580 [ "To install the correct GHC into " 581 , T.pack (toFilePath (configLocalPrograms config)) 582 , ", try running \"stack setup\" or use the \"--install-ghc\" flag." 583 , " To use your system GHC installation, run \"stack config set system-ghc --global true\", or use the \"--system-ghc\" flag." 584 ]) 585 (soptsResolveMissingGHC sopts) 586 throwM $ CompilerVersionMismatch 587 Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem) 588 (soptsWantedCompiler sopts, expectedArch) 589 ghcVariant 590 (case possibleCompilers of 591 [] -> CompilerBuildStandard 592 (_, compilerBuild):_ -> compilerBuild) 593 (soptsCompilerCheck sopts) 594 (soptsStackYaml sopts) 595 suggestion 596 597-- | Ensure compiler is installed, without worrying about msys 598ensureCompiler 599 :: forall env. (HasBuildConfig env, HasGHCVariant env) 600 => SetupOpts 601 -> Memoized SetupInfo 602 -> RIO env (CompilerPaths, ExtraDirs) 603ensureCompiler sopts getSetupInfo' = do 604 let wanted = soptsWantedCompiler sopts 605 wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted 606 607 Platform expectedArch _ <- view platformL 608 609 let canUseCompiler cp 610 | soptsSkipGhcCheck sopts = pure cp 611 | not $ isWanted $ cpCompilerVersion cp = throwString "Not the compiler version we want" 612 | cpArch cp /= expectedArch = throwString "Not the architecture we want" 613 | otherwise = pure cp 614 isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) 615 616 let checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths) 617 checkCompiler compiler = do 618 eres <- tryAny $ pathsFromCompiler wc CompilerBuildStandard False compiler >>= canUseCompiler 619 case eres of 620 Left e -> do 621 logDebug $ "Not using compiler at " <> displayShow (toFilePath compiler) <> ": " <> displayShow e 622 pure Nothing 623 Right cp -> pure $ Just cp 624 625 mcp <- 626 if soptsUseSystem sopts 627 then do 628 logDebug "Getting system compiler version" 629 runConduit $ 630 sourceSystemCompilers wanted .| 631 concatMapMC checkCompiler .| 632 await 633 else return Nothing 634 case mcp of 635 Nothing -> ensureSandboxedCompiler sopts getSetupInfo' 636 Just cp -> do 637 let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] } 638 pure (cp, paths) 639 640ensureSandboxedCompiler 641 :: HasBuildConfig env 642 => SetupOpts 643 -> Memoized SetupInfo 644 -> RIO env (CompilerPaths, ExtraDirs) 645ensureSandboxedCompiler sopts getSetupInfo' = do 646 let wanted = soptsWantedCompiler sopts 647 -- List installed tools 648 config <- view configL 649 let localPrograms = configLocalPrograms config 650 installed <- listInstalled localPrograms 651 logDebug $ "Installed tools: \n - " <> mconcat (intersperse "\n - " (map (fromString . toolString) installed)) 652 (compilerTool, compilerBuild) <- 653 case soptsWantedCompiler sopts of 654 -- shall we build GHC from source? 655 WCGhcGit commitId flavour -> buildGhcFromSource getSetupInfo' installed (configCompilerRepository config) commitId flavour 656 _ -> installGhcBindist sopts getSetupInfo' installed 657 paths <- extraDirs compilerTool 658 659 wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted 660 menv0 <- view processContextL 661 m <- either throwM return 662 $ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0) 663 menv <- mkProcessContext (removeHaskellEnvVars m) 664 665 names <- 666 case wanted of 667 WCGhc version -> pure ["ghc-" ++ versionString version, "ghc"] 668 WCGhcGit{} -> pure ["ghc"] 669 WCGhcjs{} -> throwIO GhcjsNotSupported 670 671 -- Previously, we used findExecutable to locate these executables. This was 672 -- actually somewhat sloppy, as it could discover executables outside of the 673 -- sandbox. This led to a specific issue on Windows with GHC 9.0.1. See 674 -- https://gitlab.haskell.org/ghc/ghc/-/issues/20074. Instead, now, we look 675 -- on the paths specified only. 676 let loop [] = do 677 logError $ "Looked for sandboxed compiler named one of: " <> displayShow names 678 logError $ "Could not find it on the paths " <> displayShow (edBins paths) 679 throwString "Could not find sandboxed compiler" 680 loop (x:xs) = do 681 res <- liftIO $ D.findExecutablesInDirectories (map toFilePath (edBins paths)) x 682 case res of 683 [] -> loop xs 684 compiler:rest -> do 685 unless (null rest) $ do 686 logWarn "Found multiple candidate compilers:" 687 for_ res $ \y -> logWarn $ "- " <> fromString y 688 logWarn $ "This usually indicates a failed installation. Trying anyway with " <> fromString compiler 689 parseAbsFile compiler 690 compiler <- withProcessContext menv $ do 691 compiler <- loop names 692 693 -- Run this here to ensure that the sanity check uses the modified 694 -- environment, otherwise we may infect GHC_PACKAGE_PATH and break sanity 695 -- checks. 696 when (soptsSanityCheck sopts) $ sanityCheck compiler 697 698 pure compiler 699 700 cp <- pathsFromCompiler wc compilerBuild True compiler 701 pure (cp, paths) 702 703pathsFromCompiler 704 :: forall env. HasConfig env 705 => WhichCompiler 706 -> CompilerBuild 707 -> Bool 708 -> Path Abs File -- ^ executable filepath 709 -> RIO env CompilerPaths 710pathsFromCompiler wc compilerBuild isSandboxed compiler = withCache $ handleAny onErr $ do 711 let dir = toFilePath $ parent compiler 712 suffixNoVersion 713 | osIsWindows = ".exe" 714 | otherwise = "" 715 msuffixWithVersion = do 716 let prefix = 717 case wc of 718 Ghc -> "ghc-" 719 fmap ("-" ++) $ stripPrefix prefix $ toFilePath $ filename compiler 720 suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion] 721 findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File) 722 findHelper getNames = do 723 let toTry = [dir ++ name ++ suffix | suffix <- suffixes, name <- getNames wc] 724 loop [] = throwString $ "Could not find any of: " <> show toTry 725 loop (guessedPath':rest) = do 726 guessedPath <- parseAbsFile guessedPath' 727 exists <- doesFileExist guessedPath 728 if exists 729 then pure guessedPath 730 else loop rest 731 logDebug $ "Looking for executable(s): " <> displayShow toTry 732 loop toTry 733 pkg <- fmap GhcPkgExe $ findHelper $ \case 734 Ghc -> ["ghc-pkg"] 735 736 menv0 <- view processContextL 737 menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0)) 738 739 interpreter <- findHelper $ 740 \case 741 Ghc -> ["runghc"] 742 haddock <- findHelper $ 743 \case 744 Ghc -> ["haddock", "haddock-ghc"] 745 infobs <- proc (toFilePath compiler) ["--info"] 746 $ fmap (toStrictBytes . fst) . readProcess_ 747 infotext <- 748 case decodeUtf8' infobs of 749 Left e -> throwString $ "GHC info is not valid UTF-8: " ++ show e 750 Right info -> pure info 751 infoPairs :: [(String, String)] <- 752 case readMaybe $ T.unpack infotext of 753 Nothing -> throwString "GHC info does not parse as a list of pairs" 754 Just infoPairs -> pure infoPairs 755 let infoMap = Map.fromList infoPairs 756 757 eglobaldb <- tryAny $ 758 case Map.lookup "Global Package DB" infoMap of 759 Nothing -> throwString "Key 'Global Package DB' not found in GHC info" 760 Just db -> parseAbsDir db 761 762 arch <- 763 case Map.lookup "Target platform" infoMap of 764 Nothing -> throwString "Key 'Target platform' not found in GHC info" 765 Just targetPlatform -> 766 case simpleParse $ takeWhile (/= '-') targetPlatform of 767 Nothing -> throwString $ "Invalid target platform in GHC info: " ++ show targetPlatform 768 Just arch -> pure arch 769 compilerVer <- 770 case wc of 771 Ghc -> 772 case Map.lookup "Project version" infoMap of 773 Nothing -> do 774 logWarn "Key 'Project version' not found in GHC info" 775 getCompilerVersion wc compiler 776 Just versionString' -> ACGhc <$> parseVersionThrowing versionString' 777 globaldb <- 778 case eglobaldb of 779 Left e -> do 780 logWarn "Parsing global DB from GHC info failed" 781 logWarn $ displayShow e 782 logWarn "Asking ghc-pkg directly" 783 withProcessContext menv $ getGlobalDB pkg 784 Right x -> pure x 785 786 globalDump <- withProcessContext menv $ globalsFromDump pkg 787 cabalPkgVer <- 788 case Map.lookup cabalPackageName globalDump of 789 Nothing -> throwString $ "Cabal library not found in global package database for " ++ toFilePath compiler 790 Just dp -> pure $ pkgVersion $ dpPackageIdent dp 791 792 return CompilerPaths 793 { cpBuild = compilerBuild 794 , cpArch = arch 795 , cpSandboxed = isSandboxed 796 , cpCompilerVersion = compilerVer 797 , cpCompiler = compiler 798 , cpPkg = pkg 799 , cpInterpreter = interpreter 800 , cpHaddock = haddock 801 , cpCabalVersion = cabalPkgVer 802 , cpGlobalDB = globaldb 803 , cpGhcInfo = infobs 804 , cpGlobalDump = globalDump 805 } 806 where 807 onErr = throwIO . InvalidGhcAt compiler 808 809 withCache inner = do 810 eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed 811 mres <- 812 case eres of 813 Left e -> do 814 logWarn $ "Trouble loading CompilerPaths cache: " <> displayShow e 815 pure Nothing 816 Right x -> pure x 817 case mres of 818 Just cp -> cp <$ logDebug "Loaded compiler information from cache" 819 Nothing -> do 820 cp <- inner 821 saveCompilerPaths cp `catchAny` \e -> 822 logWarn ("Unable to save CompilerPaths cache: " <> displayShow e) 823 pure cp 824 825buildGhcFromSource :: forall env. 826 ( HasTerm env 827 , HasProcessContext env 828 , HasBuildConfig env 829 ) => Memoized SetupInfo -> [Tool] -> CompilerRepository -> Text -> Text 830 -> RIO env (Tool, CompilerBuild) 831buildGhcFromSource getSetupInfo' installed (CompilerRepository url) commitId flavour = do 832 config <- view configL 833 let compilerTool = ToolGhcGit commitId flavour 834 835 -- detect when the correct GHC is already installed 836 if compilerTool `elem` installed 837 then return (compilerTool,CompilerBuildStandard) 838 else do 839 let repo = Repo 840 { repoCommit = commitId 841 , repoUrl = url 842 , repoType = RepoGit 843 , repoSubdir = mempty 844 } 845 846 -- clone the repository and execute the given commands 847 Pantry.withRepo repo $ do 848 -- withRepo is guaranteed to set workingDirL, so let's get it 849 mcwd <- traverse parseAbsDir =<< view workingDirL 850 let cwd = fromMaybe (error "Invalid working directory") mcwd 851 852 threads <- view $ configL.to configJobs 853 let 854 hadrianArgs = fmap T.unpack 855 [ "-c" -- run ./boot and ./configure 856 , "-j" <> tshow threads -- parallel build 857 , "--flavour=" <> flavour -- selected flavour 858 , "binary-dist" 859 ] 860 hadrianScripts 861 | osIsWindows = hadrianScriptsWindows 862 | otherwise = hadrianScriptsPosix 863 864 foundHadrianPaths <- filterM doesFileExist $ (cwd </>) <$> hadrianScripts 865 hadrianPath <- maybe (throwString "No Hadrian build script found") pure $ listToMaybe foundHadrianPaths 866 867 logSticky $ "Building GHC from source with `" 868 <> RIO.display flavour 869 <> "` flavour. It can take a long time (more than one hour)..." 870 871 -- We need to provide an absolute path to the script since 872 -- the process package only sets working directory _after_ 873 -- discovering the executable 874 proc (toFilePath hadrianPath) hadrianArgs runProcess_ 875 876 -- find the bindist and install it 877 bindistPath <- parseRelDir "_build/bindist" 878 (_,files) <- listDir (cwd </> bindistPath) 879 let 880 isBindist p = do 881 extension <- fileExtension (filename p) 882 883 return $ "ghc-" `isPrefixOf` (toFilePath (filename p)) 884 && extension == ".xz" 885 886 mbindist <- filterM isBindist files 887 case mbindist of 888 [bindist] -> do 889 let bindist' = T.pack (toFilePath bindist) 890 dlinfo = DownloadInfo 891 { downloadInfoUrl = bindist' 892 -- we can specify a filepath instead of a URL 893 , downloadInfoContentLength = Nothing 894 , downloadInfoSha1 = Nothing 895 , downloadInfoSha256 = Nothing 896 } 897 ghcdlinfo = GHCDownloadInfo mempty mempty dlinfo 898 installer 899 | osIsWindows = installGHCWindows 900 | otherwise = installGHCPosix ghcdlinfo 901 si <- runMemoized getSetupInfo' 902 _ <- downloadAndInstallTool 903 (configLocalPrograms config) 904 dlinfo 905 compilerTool 906 (installer si) 907 return (compilerTool, CompilerBuildStandard) 908 _ -> do 909 forM_ files (logDebug . fromString . (" - " ++) . toFilePath) 910 error "Can't find hadrian generated bindist" 911 912 913-- | Determine which GHC builds to use depending on which shared libraries are available 914-- on the system. 915getGhcBuilds :: HasConfig env => RIO env [CompilerBuild] 916getGhcBuilds = do 917 918 config <- view configL 919 case configGHCBuild config of 920 Just ghcBuild -> return [ghcBuild] 921 Nothing -> determineGhcBuild 922 where 923 determineGhcBuild = do 924 -- TODO: a more reliable, flexible, and data driven approach would be to actually download small 925 -- "test" executables (from setup-info) that link to the same gmp/tinfo versions 926 -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go 927 -- something like this: 928 -- 929 -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache 930 -- if cached, then use that as suffix 931 -- otherwise: 932 -- download setup-info 933 -- go through all with right prefix for os/version/variant 934 -- first try "standard" (no extra suffix), then the rest 935 -- download "compatibility check" exe if not already downloaded 936 -- try running it 937 -- if successful, then choose that 938 -- cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version 939 -- 940 -- Of course, could also try to make a static GHC bindist instead of all this rigamarole. 941 942 platform <- view platformL 943 case platform of 944 Platform _ Cabal.Linux -> do 945 -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well 946 let sbinEnv m = Map.insert 947 "PATH" 948 ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m)) 949 m 950 eldconfigOut 951 <- withModifyEnvVars sbinEnv 952 $ proc "ldconfig" ["-p"] 953 $ tryAny . fmap fst . readProcess_ 954 let firstWords = case eldconfigOut of 955 Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $ 956 T.lines $ T.decodeUtf8With T.lenientDecode 957 $ LBS.toStrict ldconfigOut 958 Left _ -> [] 959 checkLib lib 960 | libT `elem` firstWords = do 961 logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output") 962 return True 963 | osIsWindows = 964 -- Cannot parse /usr/lib on Windows 965 return False 966 | otherwise = do 967 -- This is a workaround for the fact that libtinfo.so.x doesn't appear in 968 -- the 'ldconfig -p' output on Arch or Slackware even when it exists. 969 -- There doesn't seem to be an easy way to get the true list of directories 970 -- to scan for shared libs, but this works for our particular cases. 971 matches <- filterM (doesFileExist .(</> lib)) usrLibDirs 972 case matches of 973 [] -> logDebug ("Did not find shared library " <> libD) 974 >> return False 975 (path:_) -> logDebug ("Found shared library " <> libD 976 <> " in " <> fromString (Path.toFilePath path)) 977 >> return True 978 where 979 libT = T.pack (toFilePath lib) 980 libD = fromString (toFilePath lib) 981 hastinfo5 <- checkLib relFileLibtinfoSo5 982 hastinfo6 <- checkLib relFileLibtinfoSo6 983 hasncurses6 <- checkLib relFileLibncurseswSo6 984 hasgmp5 <- checkLib relFileLibgmpSo10 985 hasgmp4 <- checkLib relFileLibgmpSo3 986 let libComponents = concat 987 [ [["tinfo6"] | hastinfo6 && hasgmp5] 988 , [[] | hastinfo5 && hasgmp5] 989 , [["ncurses6"] | hasncurses6 && hasgmp5 ] 990 , [["gmp4"] | hasgmp4 ] 991 ] 992 useBuilds $ map 993 (\c -> case c of 994 [] -> CompilerBuildStandard 995 _ -> CompilerBuildSpecialized (intercalate "-" c)) 996 libComponents 997 Platform _ Cabal.FreeBSD -> do 998 let getMajorVer = readMaybe <=< headMaybe . (splitOn ".") 999 majorVer <- getMajorVer <$> sysRelease 1000 if majorVer >= Just (12 :: Int) then 1001 useBuilds [CompilerBuildSpecialized "ino64"] 1002 else 1003 useBuilds [CompilerBuildStandard] 1004 Platform _ Cabal.OpenBSD -> do 1005 releaseStr <- mungeRelease <$> sysRelease 1006 useBuilds [CompilerBuildSpecialized releaseStr] 1007 _ -> useBuilds [CompilerBuildStandard] 1008 useBuilds builds = do 1009 logDebug $ 1010 "Potential GHC builds: " <> 1011 mconcat (intersperse ", " (map (fromString . compilerBuildName) builds)) 1012 return builds 1013 1014-- | Encode an OpenBSD version (like "6.1") into a valid argument for 1015-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed 1016-- with "r". 1017-- The result r must be such that "ghc-" ++ r is a valid package name, 1018-- as recognized by parsePackageNameFromString. 1019mungeRelease :: String -> String 1020mungeRelease = intercalate "-" . prefixMaj . splitOn "." 1021 where 1022 prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs 1023 prefixFst _ _ [] = [] 1024 prefixMaj = prefixFst "maj" prefixMin 1025 prefixMin = prefixFst "min" (map ('r':)) 1026 1027sysRelease :: HasLogFunc env => RIO env String 1028sysRelease = 1029 handleIO (\e -> do 1030 logWarn $ "Could not query OS version: " <> displayShow e 1031 return "") 1032 (liftIO getRelease) 1033 1034-- | Ensure Docker container-compatible 'stack' executable is downloaded 1035ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File) 1036ensureDockerStackExe containerPlatform = do 1037 config <- view configL 1038 containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone) 1039 let programsPath = configLocalProgramsBase config </> containerPlatformDir 1040 tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion) 1041 stackExeDir <- installDir programsPath tool 1042 let stackExePath = stackExeDir </> relFileStack 1043 stackExeExists <- doesFileExist stackExePath 1044 unless stackExeExists $ do 1045 logInfo $ 1046 "Downloading Docker-compatible " <> 1047 fromString stackProgName <> 1048 " executable" 1049 sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion)) 1050 platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone) 1051 downloadStackExe platforms sri stackExeDir False (const $ return ()) 1052 return stackExePath 1053 1054-- | Get all executables on the path that might match the wanted compiler 1055sourceSystemCompilers 1056 :: (HasProcessContext env, HasLogFunc env) 1057 => WantedCompiler 1058 -> ConduitT i (Path Abs File) (RIO env) () 1059sourceSystemCompilers wanted = do 1060 searchPath <- view exeSearchPathL 1061 names <- 1062 case wanted of 1063 WCGhc version -> pure 1064 [ "ghc-" ++ versionString version 1065 , "ghc" 1066 ] 1067 WCGhcjs{} -> throwIO GhcjsNotSupported 1068 WCGhcGit{} -> pure [] -- only use sandboxed versions 1069 for_ names $ \name -> for_ searchPath $ \dir -> do 1070 fp <- resolveFile' $ addExe $ dir FP.</> name 1071 exists <- doesFileExist fp 1072 when exists $ yield fp 1073 where 1074 addExe 1075 | osIsWindows = (++ ".exe") 1076 | otherwise = id 1077 1078-- | Download the most recent SetupInfo 1079getSetupInfo :: HasConfig env => RIO env SetupInfo 1080getSetupInfo = do 1081 config <- view configL 1082 let inlineSetupInfo = configSetupInfoInline config 1083 locations' = configSetupInfoLocations config 1084 locations = if null locations' then [defaultSetupInfoYaml] else locations' 1085 1086 resolvedSetupInfos <- mapM loadSetupInfo locations 1087 return (inlineSetupInfo <> mconcat resolvedSetupInfos) 1088 where 1089 loadSetupInfo urlOrFile = do 1090 bs <- 1091 case parseUrlThrow urlOrFile of 1092 Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req 1093 Nothing -> liftIO $ S.readFile urlOrFile 1094 WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs) 1095 when (urlOrFile /= defaultSetupInfoYaml) $ 1096 logJSONWarnings urlOrFile warnings 1097 return si 1098 1099getInstalledTool :: [Tool] -- ^ already installed 1100 -> PackageName -- ^ package to find 1101 -> (Version -> Bool) -- ^ which versions are acceptable 1102 -> Maybe Tool 1103getInstalledTool installed name goodVersion = 1104 if null available 1105 then Nothing 1106 else Just $ Tool $ maximumBy (comparing pkgVersion) available 1107 where 1108 available = mapMaybe goodPackage installed 1109 goodPackage (Tool pi') = 1110 if pkgName pi' == name && 1111 goodVersion (pkgVersion pi') 1112 then Just pi' 1113 else Nothing 1114 goodPackage _ = Nothing 1115 1116downloadAndInstallTool :: (HasTerm env, HasBuildConfig env) 1117 => Path Abs Dir 1118 -> DownloadInfo 1119 -> Tool 1120 -> (Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ()) 1121 -> RIO env Tool 1122downloadAndInstallTool programsDir downloadInfo tool installer = do 1123 ensureDir programsDir 1124 (file, at) <- downloadFromInfo programsDir downloadInfo tool 1125 dir <- installDir programsDir tool 1126 tempDir <- tempInstallDir programsDir tool 1127 liftIO $ ignoringAbsence (removeDirRecur tempDir) 1128 ensureDir tempDir 1129 unmarkInstalled programsDir tool 1130 installer file at tempDir dir 1131 markInstalled programsDir tool 1132 liftIO $ ignoringAbsence (removeDirRecur tempDir) 1133 return tool 1134 1135downloadAndInstallCompiler :: (HasBuildConfig env, HasGHCVariant env) 1136 => CompilerBuild 1137 -> SetupInfo 1138 -> WantedCompiler 1139 -> VersionCheck 1140 -> Maybe String 1141 -> RIO env Tool 1142downloadAndInstallCompiler ghcBuild si wanted@(WCGhc version) versionCheck mbindistURL = do 1143 ghcVariant <- view ghcVariantL 1144 (selectedVersion, downloadInfo) <- case mbindistURL of 1145 Just bindistURL -> do 1146 case ghcVariant of 1147 GHCCustom _ -> return () 1148 _ -> throwM RequireCustomGHCVariant 1149 return (version, GHCDownloadInfo mempty mempty DownloadInfo 1150 { downloadInfoUrl = T.pack bindistURL 1151 , downloadInfoContentLength = Nothing 1152 , downloadInfoSha1 = Nothing 1153 , downloadInfoSha256 = Nothing 1154 }) 1155 _ -> do 1156 ghcKey <- getGhcKey ghcBuild 1157 case Map.lookup ghcKey $ siGHCs si of 1158 Nothing -> throwM $ UnknownOSKey ghcKey 1159 Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_ 1160 config <- view configL 1161 let installer = 1162 case configPlatform config of 1163 Platform _ Cabal.Windows -> installGHCWindows 1164 _ -> installGHCPosix downloadInfo 1165 logInfo $ 1166 "Preparing to install GHC" <> 1167 (case ghcVariant of 1168 GHCStandard -> "" 1169 v -> " (" <> fromString (ghcVariantName v) <> ")") <> 1170 (case ghcBuild of 1171 CompilerBuildStandard -> "" 1172 b -> " (" <> fromString (compilerBuildName b) <> ")") <> 1173 " to an isolated location." 1174 logInfo "This will not interfere with any system-level installation." 1175 ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) 1176 let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion 1177 downloadAndInstallTool (configLocalPrograms config) (gdiDownloadInfo downloadInfo) tool (installer si) 1178 1179downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO GhcjsNotSupported 1180 1181downloadAndInstallCompiler _ _ WCGhcGit{} _ _ = 1182 error "downloadAndInstallCompiler: shouldn't be reached with ghc-git" 1183 1184getWantedCompilerInfo :: (Ord k, MonadThrow m) 1185 => Text 1186 -> VersionCheck 1187 -> WantedCompiler 1188 -> (k -> ActualCompiler) 1189 -> Map k a 1190 -> m (k, a) 1191getWantedCompilerInfo key versionCheck wanted toCV pairs_ = 1192 case mpair of 1193 Just pair -> return pair 1194 Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_)) 1195 where 1196 mpair = 1197 listToMaybe $ 1198 sortBy (flip (comparing fst)) $ 1199 filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) 1200 1201-- | Download and install the first available compiler build. 1202downloadAndInstallPossibleCompilers 1203 :: (HasGHCVariant env, HasBuildConfig env) 1204 => [CompilerBuild] 1205 -> SetupInfo 1206 -> WantedCompiler 1207 -> VersionCheck 1208 -> Maybe String 1209 -> RIO env (Tool, CompilerBuild) 1210downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL = 1211 go possibleCompilers Nothing 1212 where 1213 -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or 1214 -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is non-existent, 1215 -- not if the download or install fails for some other reason). 1216 -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception 1217 -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any 1218 -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions 1219 -- are unioned). 1220 go [] Nothing = throwM UnsupportedSetupConfiguration 1221 go [] (Just e) = throwM e 1222 go (b:bs) e = do 1223 logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b) 1224 er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL 1225 case er of 1226 Left e'@(UnknownCompilerVersion ks' w' vs') -> 1227 case e of 1228 Nothing -> go bs (Just e') 1229 Just (UnknownOSKey k) -> 1230 go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs' 1231 Just (UnknownCompilerVersion ks _ vs) -> 1232 go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs) 1233 Just x -> throwM x 1234 Left e'@(UnknownOSKey k') -> 1235 case e of 1236 Nothing -> go bs (Just e') 1237 Just (UnknownOSKey _) -> go bs e 1238 Just (UnknownCompilerVersion ks w vs) -> 1239 go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs 1240 Just x -> throwM x 1241 Left e' -> throwM e' 1242 Right r -> return (r, b) 1243 1244getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) 1245 => CompilerBuild -> m Text 1246getGhcKey ghcBuild = do 1247 ghcVariant <- view ghcVariantL 1248 platform <- view platformL 1249 osKey <- getOSKey platform 1250 return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild) 1251 1252getOSKey :: (MonadThrow m) 1253 => Platform -> m Text 1254getOSKey platform = 1255 case platform of 1256 Platform I386 Cabal.Linux -> return "linux32" 1257 Platform X86_64 Cabal.Linux -> return "linux64" 1258 Platform I386 Cabal.OSX -> return "macosx" 1259 Platform X86_64 Cabal.OSX -> return "macosx" 1260 Platform I386 Cabal.FreeBSD -> return "freebsd32" 1261 Platform X86_64 Cabal.FreeBSD -> return "freebsd64" 1262 Platform I386 Cabal.OpenBSD -> return "openbsd32" 1263 Platform X86_64 Cabal.OpenBSD -> return "openbsd64" 1264 Platform I386 Cabal.Windows -> return "windows32" 1265 Platform X86_64 Cabal.Windows -> return "windows64" 1266 Platform Arm Cabal.Linux -> return "linux-armv7" 1267 Platform AArch64 Cabal.Linux -> return "linux-aarch64" 1268 Platform Sparc Cabal.Linux -> return "linux-sparc" 1269 Platform AArch64 Cabal.FreeBSD -> return "freebsd-aarch64" 1270 Platform arch os -> throwM $ UnsupportedSetupCombo os arch 1271 1272downloadOrUseLocal 1273 :: (HasTerm env, HasBuildConfig env) 1274 => Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File) 1275downloadOrUseLocal downloadLabel downloadInfo destination = 1276 case url of 1277 (parseUrlThrow -> Just _) -> do 1278 ensureDir (parent destination) 1279 chattyDownload downloadLabel downloadInfo destination 1280 return destination 1281 (parseAbsFile -> Just path) -> do 1282 warnOnIgnoredChecks 1283 return path 1284 (parseRelFile -> Just path) -> do 1285 warnOnIgnoredChecks 1286 root <- view projectRootL 1287 return (root </> path) 1288 _ -> 1289 throwString $ "Error: `url` must be either an HTTP URL or a file path: " ++ url 1290 where 1291 url = T.unpack $ downloadInfoUrl downloadInfo 1292 warnOnIgnoredChecks = do 1293 let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1, 1294 downloadInfoSha256=sha256} = downloadInfo 1295 when (isJust contentLength) $ 1296 logWarn "`content-length` is not checked and should not be specified when `url` is a file path" 1297 when (isJust sha1) $ 1298 logWarn "`sha1` is not checked and should not be specified when `url` is a file path" 1299 when (isJust sha256) $ 1300 logWarn "`sha256` is not checked and should not be specified when `url` is a file path" 1301 1302downloadFromInfo 1303 :: (HasTerm env, HasBuildConfig env) 1304 => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType) 1305downloadFromInfo programsDir downloadInfo tool = do 1306 archiveType <- 1307 case extension of 1308 ".tar.xz" -> return TarXz 1309 ".tar.bz2" -> return TarBz2 1310 ".tar.gz" -> return TarGz 1311 ".7z.exe" -> return SevenZ 1312 _ -> throwString $ "Error: Unknown extension for url: " ++ url 1313 1314 relativeFile <- parseRelFile $ toolString tool ++ extension 1315 let destinationPath = programsDir </> relativeFile 1316 localPath <- downloadOrUseLocal (T.pack (toolString tool)) downloadInfo destinationPath 1317 return (localPath, archiveType) 1318 1319 where 1320 url = T.unpack $ downloadInfoUrl downloadInfo 1321 extension = loop url 1322 where 1323 loop fp 1324 | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext 1325 | otherwise = "" 1326 where 1327 (fp', ext) = FP.splitExtension fp 1328 1329 1330data ArchiveType 1331 = TarBz2 1332 | TarXz 1333 | TarGz 1334 | SevenZ 1335 1336installGHCPosix :: HasConfig env 1337 => GHCDownloadInfo 1338 -> SetupInfo 1339 -> Path Abs File 1340 -> ArchiveType 1341 -> Path Abs Dir 1342 -> Path Abs Dir 1343 -> RIO env () 1344installGHCPosix downloadInfo _ archiveFile archiveType tempDir destDir = do 1345 platform <- view platformL 1346 menv0 <- view processContextL 1347 menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0)) 1348 logDebug $ "menv = " <> displayShow (view envVarsL menv) 1349 (zipTool', compOpt) <- 1350 case archiveType of 1351 TarXz -> return ("xz", 'J') 1352 TarBz2 -> return ("bzip2", 'j') 1353 TarGz -> return ("gzip", 'z') 1354 SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows" 1355 -- Slight hack: OpenBSD's tar doesn't support xz. 1356 -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986 1357 let tarDep = 1358 case (platform, archiveType) of 1359 (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar" 1360 _ -> checkDependency "tar" 1361 (zipTool, makeTool, tarTool) <- checkDependencies $ (,,) 1362 <$> checkDependency zipTool' 1363 <*> (checkDependency "gmake" <|> checkDependency "make") 1364 <*> tarDep 1365 1366 logDebug $ "ziptool: " <> fromString zipTool 1367 logDebug $ "make: " <> fromString makeTool 1368 logDebug $ "tar: " <> fromString tarTool 1369 1370 let runStep step wd env cmd args = do 1371 menv' <- modifyEnvVars menv (Map.union env) 1372 let logLines lvl = CB.lines .| CL.mapM_ (lvl . displayBytesUtf8) 1373 logStdout = logLines logDebug 1374 logStderr = logLines logError 1375 void $ withWorkingDir (toFilePath wd) $ 1376 withProcessContext menv' $ 1377 sinkProcessStderrStdout cmd args logStderr logStdout 1378 `catchAny` \ex -> do 1379 logError $ displayShow ex 1380 prettyError $ hang 2 ( 1381 "Error encountered while" <+> step <+> "GHC with" 1382 <> line <> 1383 style Shell (fromString (unwords (cmd : args))) 1384 <> line <> 1385 -- TODO: Figure out how to insert \ in the appropriate spots 1386 -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <> 1387 "run in " <> pretty wd 1388 ) 1389 <> line <> line <> 1390 "The following directories may now contain files, but won't be used by stack:" 1391 <> line <> 1392 " -" <+> pretty tempDir 1393 <> line <> 1394 " -" <+> pretty destDir 1395 <> line <> line <> 1396 "For more information consider rerunning with --verbose flag" 1397 <> line 1398 exitFailure 1399 1400 logSticky $ 1401 "Unpacking GHC into " <> 1402 fromString (toFilePath tempDir) <> 1403 " ..." 1404 logDebug $ "Unpacking " <> fromString (toFilePath archiveFile) 1405 runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile] 1406 1407 dir <- expectSingleUnpackedDir archiveFile tempDir 1408 1409 logSticky "Configuring GHC ..." 1410 runStep "configuring" dir 1411 (gdiConfigureEnv downloadInfo) 1412 (toFilePath $ dir </> relFileConfigure) 1413 (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo)) 1414 1415 logSticky "Installing GHC ..." 1416 runStep "installing" dir mempty makeTool ["install"] 1417 1418 logStickyDone $ "Installed GHC." 1419 logDebug $ "GHC installed to " <> fromString (toFilePath destDir) 1420 1421-- | Check if given processes appear to be present, throwing an exception if 1422-- missing. 1423checkDependencies :: CheckDependency env a -> RIO env a 1424checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return 1425 1426checkDependency :: HasProcessContext env => String -> CheckDependency env String 1427checkDependency tool = CheckDependency $ do 1428 exists <- doesExecutableExist tool 1429 return $ if exists then Right tool else Left [tool] 1430 1431newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a)) 1432 deriving Functor 1433instance Applicative (CheckDependency env) where 1434 pure x = CheckDependency $ return (Right x) 1435 CheckDependency f <*> CheckDependency x = CheckDependency $ do 1436 f' <- f 1437 x' <- x 1438 return $ 1439 case (f', x') of 1440 (Left e1, Left e2) -> Left $ e1 ++ e2 1441 (Left e, Right _) -> Left e 1442 (Right _, Left e) -> Left e 1443 (Right f'', Right x'') -> Right $ f'' x'' 1444instance Alternative (CheckDependency env) where 1445 empty = CheckDependency $ return $ Left [] 1446 CheckDependency x <|> CheckDependency y = CheckDependency $ do 1447 res1 <- x 1448 case res1 of 1449 Left _ -> y 1450 Right x' -> return $ Right x' 1451 1452installGHCWindows :: HasBuildConfig env 1453 => SetupInfo 1454 -> Path Abs File 1455 -> ArchiveType 1456 -> Path Abs Dir 1457 -> Path Abs Dir 1458 -> RIO env () 1459installGHCWindows si archiveFile archiveType _tempDir destDir = do 1460 withUnpackedTarball7z "GHC" si archiveFile archiveType destDir 1461 logInfo $ "GHC installed to " <> fromString (toFilePath destDir) 1462 1463installMsys2Windows :: HasBuildConfig env 1464 => SetupInfo 1465 -> Path Abs File 1466 -> ArchiveType 1467 -> Path Abs Dir 1468 -> Path Abs Dir 1469 -> RIO env () 1470installMsys2Windows si archiveFile archiveType _tempDir destDir = do 1471 exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir 1472 when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do 1473 logError $ 1474 "Could not delete existing msys directory: " <> 1475 fromString (toFilePath destDir) 1476 throwM e 1477 1478 withUnpackedTarball7z "MSYS2" si archiveFile archiveType destDir 1479 1480 1481 -- I couldn't find this officially documented anywhere, but you need to run 1482 -- the MSYS shell once in order to initialize some pacman stuff. Once that 1483 -- run happens, you can just run commands as usual. 1484 menv0 <- view processContextL 1485 newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS" 1486 newEnv <- either throwM return $ augmentPathMap 1487 [toFilePath $ destDir </> relDirUsr </> relDirBin] 1488 (view envVarsL newEnv0) 1489 menv <- mkProcessContext newEnv 1490 withWorkingDir (toFilePath destDir) $ withProcessContext menv 1491 $ proc "sh" ["--login", "-c", "true"] runProcess_ 1492 1493 -- No longer installing git, it's unreliable 1494 -- (https://github.com/commercialhaskell/stack/issues/1046) and the 1495 -- MSYS2-installed version has bad CRLF defaults. 1496 -- 1497 -- Install git. We could install other useful things in the future too. 1498 -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing 1499 1500-- | Unpack a compressed tarball using 7zip. Expects a single directory in 1501-- the unpacked results, which is renamed to the destination directory. 1502withUnpackedTarball7z :: HasBuildConfig env 1503 => String -- ^ Name of tool, used in error messages 1504 -> SetupInfo 1505 -> Path Abs File -- ^ Path to archive file 1506 -> ArchiveType 1507 -> Path Abs Dir -- ^ Destination directory. 1508 -> RIO env () 1509withUnpackedTarball7z name si archiveFile archiveType destDir = do 1510 suffix <- 1511 case archiveType of 1512 TarXz -> return ".xz" 1513 TarBz2 -> return ".bz2" 1514 TarGz -> return ".gz" 1515 _ -> throwString $ name ++ " must be a tarball file" 1516 tarFile <- 1517 case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of 1518 Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile 1519 Just x -> parseRelFile $ T.unpack x 1520 run7z <- setup7z si 1521 let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" 1522 ensureDir (parent destDir) 1523 withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do 1524 liftIO $ ignoringAbsence (removeDirRecur destDir) 1525 run7z tmpDir archiveFile 1526 run7z tmpDir (tmpDir </> tarFile) 1527 absSrcDir <- expectSingleUnpackedDir archiveFile tmpDir 1528 renameDir absSrcDir destDir 1529 1530expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir) 1531expectSingleUnpackedDir archiveFile destDir = do 1532 contents <- listDir destDir 1533 case contents of 1534 ([dir], _ ) -> return dir 1535 _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile 1536 1537-- | Download 7z as necessary, and get a function for unpacking things. 1538-- 1539-- Returned function takes an unpack directory and archive. 1540setup7z :: (HasBuildConfig env, MonadIO m) 1541 => SetupInfo 1542 -> RIO env (Path Abs Dir -> Path Abs File -> m ()) 1543setup7z si = do 1544 dir <- view $ configL.to configLocalPrograms 1545 ensureDir dir 1546 let exeDestination = dir </> relFile7zexe 1547 dllDestination = dir </> relFile7zdll 1548 case (siSevenzDll si, siSevenzExe si) of 1549 (Just sevenzDll, Just sevenzExe) -> do 1550 _ <- downloadOrUseLocal "7z.dll" sevenzDll dllDestination 1551 exePath <- downloadOrUseLocal "7z.exe" sevenzExe exeDestination 1552 withRunInIO $ \run -> return $ \outdir archive -> liftIO $ run $ do 1553 let cmd = toFilePath exePath 1554 args = 1555 [ "x" 1556 , "-o" ++ toFilePath outdir 1557 , "-y" 1558 , toFilePath archive 1559 ] 1560 let archiveDisplay = fromString $ FP.takeFileName $ toFilePath archive 1561 isExtract = FP.takeExtension (toFilePath archive) == ".tar" 1562 logInfo $ 1563 (if isExtract then "Extracting " else "Decompressing ") <> 1564 archiveDisplay <> "..." 1565 ec <- 1566 proc cmd args $ \pc -> 1567 if isExtract 1568 then withProcessWait (setStdout createSource pc) $ \p -> do 1569 total <- runConduit 1570 $ getStdout p 1571 .| filterCE (== 10) -- newline characters 1572 .| foldMC 1573 (\count bs -> do 1574 let count' = count + S.length bs 1575 logSticky $ "Extracted " <> RIO.display count' <> " files" 1576 pure count' 1577 ) 1578 0 1579 logStickyDone $ 1580 "Extracted total of " <> 1581 RIO.display total <> 1582 " files from " <> 1583 archiveDisplay 1584 waitExitCode p 1585 else runProcess pc 1586 when (ec /= ExitSuccess) 1587 $ liftIO $ throwM (ProblemWhileDecompressing archive) 1588 _ -> throwM SetupInfoMissingSevenz 1589 1590chattyDownload :: HasTerm env 1591 => Text -- ^ label 1592 -> DownloadInfo -- ^ URL, content-length, sha1, and sha256 1593 -> Path Abs File -- ^ destination 1594 -> RIO env () 1595chattyDownload label downloadInfo path = do 1596 let url = downloadInfoUrl downloadInfo 1597 req <- parseUrlThrow $ T.unpack url 1598 logSticky $ 1599 "Preparing to download " <> 1600 RIO.display label <> 1601 " ..." 1602 logDebug $ 1603 "Downloading from " <> 1604 RIO.display url <> 1605 " to " <> 1606 fromString (toFilePath path) <> 1607 " ..." 1608 hashChecks <- fmap catMaybes $ forM 1609 [ ("sha1", HashCheck SHA1, downloadInfoSha1) 1610 , ("sha256", HashCheck SHA256, downloadInfoSha256) 1611 ] 1612 $ \(name, constr, getter) -> 1613 case getter downloadInfo of 1614 Just bs -> do 1615 logDebug $ 1616 "Will check against " <> 1617 name <> 1618 " hash: " <> 1619 displayBytesUtf8 bs 1620 return $ Just $ constr $ CheckHexDigestByteString bs 1621 Nothing -> return Nothing 1622 when (null hashChecks) $ logWarn $ 1623 "No sha1 or sha256 found in metadata," <> 1624 " download hash won't be checked." 1625 let dReq = setHashChecks hashChecks $ 1626 setLengthCheck mtotalSize $ 1627 mkDownloadRequest req 1628 x <- verifiedDownloadWithProgress dReq path label mtotalSize 1629 if x 1630 then logStickyDone ("Downloaded " <> RIO.display label <> ".") 1631 else logStickyDone "Already downloaded." 1632 where 1633 mtotalSize = downloadInfoContentLength downloadInfo 1634 1635-- | Perform a basic sanity check of GHC 1636sanityCheck :: (HasProcessContext env, HasLogFunc env) 1637 => Path Abs File -> RIO env () 1638sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do 1639 let fp = toFilePath $ dir </> relFileMainHs 1640 liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines 1641 [ "import Distribution.Simple" -- ensure Cabal library is present 1642 , "main = putStrLn \"Hello World\"" 1643 ] 1644 logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc) 1645 eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc) 1646 [ fp 1647 , "-no-user-package-db" 1648 ] $ try . readProcess_ 1649 case eres of 1650 Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc 1651 Right _ -> return () -- TODO check that the output of running the command is correct 1652 1653-- Remove potentially confusing environment variables 1654removeHaskellEnvVars :: Map Text Text -> Map Text Text 1655removeHaskellEnvVars = 1656 Map.delete "GHC_PACKAGE_PATH" . 1657 Map.delete "GHC_ENVIRONMENT" . 1658 Map.delete "HASKELL_PACKAGE_SANDBOX" . 1659 Map.delete "HASKELL_PACKAGE_SANDBOXES" . 1660 Map.delete "HASKELL_DIST_DIR" . 1661 -- https://github.com/commercialhaskell/stack/issues/1460 1662 Map.delete "DESTDIR" . 1663 -- https://github.com/commercialhaskell/stack/issues/3444 1664 Map.delete "GHCRTS" 1665 1666-- | Get map of environment variables to set to change the GHC's encoding to UTF-8 1667getUtf8EnvVars 1668 :: (HasProcessContext env, HasPlatform env, HasLogFunc env) 1669 => ActualCompiler 1670 -> RIO env (Map Text Text) 1671getUtf8EnvVars compilerVer = 1672 if getGhcVersion compilerVer >= mkVersion [7, 10, 3] 1673 -- GHC_CHARENC supported by GHC >=7.10.3 1674 then return $ Map.singleton "GHC_CHARENC" "UTF-8" 1675 else legacyLocale 1676 where 1677 legacyLocale = do 1678 menv <- view processContextL 1679 Platform _ os <- view platformL 1680 if os == Cabal.Windows 1681 then 1682 -- On Windows, locale is controlled by the code page, so we don't set any environment 1683 -- variables. 1684 return 1685 Map.empty 1686 else do 1687 let checkedVars = map checkVar (Map.toList $ view envVarsL menv) 1688 -- List of environment variables that will need to be updated to set UTF-8 (because 1689 -- they currently do not specify UTF-8). 1690 needChangeVars = concatMap fst checkedVars 1691 -- Set of locale-related environment variables that have already have a value. 1692 existingVarNames = Set.unions (map snd checkedVars) 1693 -- True if a locale is already specified by one of the "global" locale variables. 1694 hasAnyExisting = 1695 any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"] 1696 if null needChangeVars && hasAnyExisting 1697 then 1698 -- If no variables need changes and at least one "global" variable is set, no 1699 -- changes to environment need to be made. 1700 return 1701 Map.empty 1702 else do 1703 -- Get a list of known locales by running @locale -a@. 1704 elocales <- tryAny $ fmap fst $ proc "locale" ["-a"] readProcess_ 1705 let 1706 -- Filter the list to only include locales with UTF-8 encoding. 1707 utf8Locales = 1708 case elocales of 1709 Left _ -> [] 1710 Right locales -> 1711 filter 1712 isUtf8Locale 1713 (T.lines $ 1714 T.decodeUtf8With 1715 T.lenientDecode $ 1716 LBS.toStrict locales) 1717 mfallback = getFallbackLocale utf8Locales 1718 when 1719 (isNothing mfallback) 1720 (logWarn 1721 "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'") 1722 let 1723 -- Get the new values of variables to adjust. 1724 changes = 1725 Map.unions $ 1726 map 1727 (adjustedVarValue menv utf8Locales mfallback) 1728 needChangeVars 1729 -- Get the values of variables to add. 1730 adds 1731 | hasAnyExisting = 1732 -- If we already have a "global" variable, then nothing needs 1733 -- to be added. 1734 Map.empty 1735 | otherwise = 1736 -- If we don't already have a "global" variable, then set LANG to the 1737 -- fallback. 1738 case mfallback of 1739 Nothing -> Map.empty 1740 Just fallback -> 1741 Map.singleton "LANG" fallback 1742 return (Map.union changes adds) 1743 -- Determines whether an environment variable is locale-related and, if so, whether it needs to 1744 -- be adjusted. 1745 checkVar 1746 :: (Text, Text) -> ([Text], Set Text) 1747 checkVar (k,v) = 1748 if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k 1749 then if isUtf8Locale v 1750 then ([], Set.singleton k) 1751 else ([k], Set.singleton k) 1752 else ([], Set.empty) 1753 -- Adjusted value of an existing locale variable. Looks for valid UTF-8 encodings with 1754 -- same language /and/ territory, then with same language, and finally the first UTF-8 locale 1755 -- returned by @locale -a@. 1756 adjustedVarValue 1757 :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text 1758 adjustedVarValue menv utf8Locales mfallback k = 1759 case Map.lookup k (view envVarsL menv) of 1760 Nothing -> Map.empty 1761 Just v -> 1762 case concatMap 1763 (matchingLocales utf8Locales) 1764 [ T.takeWhile (/= '.') v <> "." 1765 , T.takeWhile (/= '_') v <> "_"] of 1766 (v':_) -> Map.singleton k v' 1767 [] -> 1768 case mfallback of 1769 Just fallback -> Map.singleton k fallback 1770 Nothing -> Map.empty 1771 -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in 1772 -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale 1773 -- -a@. 1774 getFallbackLocale 1775 :: [Text] -> Maybe Text 1776 getFallbackLocale utf8Locales = 1777 case concatMap (matchingLocales utf8Locales) fallbackPrefixes of 1778 (v:_) -> Just v 1779 [] -> 1780 case utf8Locales of 1781 [] -> Nothing 1782 (v:_) -> Just v 1783 -- Filter the list of locales for any with the given prefixes (case-insitive). 1784 matchingLocales 1785 :: [Text] -> Text -> [Text] 1786 matchingLocales utf8Locales prefix = 1787 filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales 1788 -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)? 1789 isUtf8Locale locale = 1790 any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes 1791 -- Prefixes of fallback locales (case-insensitive) 1792 fallbackPrefixes = ["C.", "en_US.", "en_"] 1793 -- Suffixes of UTF-8 locales (case-insensitive) 1794 utf8Suffixes = [".UTF-8", ".utf8"] 1795 1796-- Binary Stack upgrades 1797 1798-- | Information on a binary release of Stack 1799data StackReleaseInfo 1800 = SRIGithub !Value 1801 -- ^ Metadata downloaded from GitHub releases about available binaries. 1802 | SRIHaskellStackOrg !HaskellStackOrg 1803 -- ^ Information on the latest available binary for the current platforms. 1804 1805data HaskellStackOrg = HaskellStackOrg 1806 { hsoUrl :: !Text 1807 , hsoVersion :: !Version 1808 } 1809 deriving Show 1810 1811downloadStackReleaseInfo 1812 :: (HasPlatform env, HasLogFunc env) 1813 => Maybe String -- Github org 1814 -> Maybe String -- Github repo 1815 -> Maybe String -- ^ optional version 1816 -> RIO env StackReleaseInfo 1817downloadStackReleaseInfo Nothing Nothing Nothing = do 1818 platform <- view platformL 1819 -- Fallback list of URLs to try for upgrading. 1820 let urls0 = 1821 case platform of 1822 Platform X86_64 Cabal.Linux -> 1823 [ "https://get.haskellstack.org/upgrade/linux-x86_64-static.tar.gz" 1824 , "https://get.haskellstack.org/upgrade/linux-x86_64.tar.gz" 1825 ] 1826 Platform X86_64 Cabal.OSX -> 1827 [ "https://get.haskellstack.org/upgrade/osx-x86_64.tar.gz" 1828 ] 1829 Platform X86_64 Cabal.Windows -> 1830 [ "https://get.haskellstack.org/upgrade/windows-x86_64.tar.gz" 1831 ] 1832 _ -> [] 1833 -- Helper function: extract the version from a GitHub releases URL. 1834 let extractVersion loc = do 1835 version0 <- 1836 case reverse $ splitOn "/" $ T.unpack loc of 1837 _final:version0:_ -> Right version0 1838 _ -> Left $ "Insufficient pieces in location: " ++ show loc 1839 version1 <- maybe (Left "no leading v on version") Right $ stripPrefix "v" version0 1840 maybe (Left $ "Invalid version: " ++ show version1) Right $ parseVersion version1 1841 1842 -- Try out different URLs. If we've exhausted all of them, fall back to GitHub. 1843 loop [] = do 1844 logDebug "Could not get binary from haskellstack.org, trying GitHub" 1845 downloadStackReleaseInfoGithub Nothing Nothing Nothing 1846 1847 -- Try the next URL 1848 loop (url:urls) = do 1849 -- Make a HEAD request without any redirects 1850 req <- setRequestMethod "HEAD" <$> parseRequest (T.unpack url) 1851 res <- httpLbs req { redirectCount = 0 } 1852 1853 -- Look for a redirect. We're looking for a standard GitHub releases 1854 -- URL where we can extract version information from. 1855 case getResponseHeader "location" res of 1856 [] -> logDebug "No location header found, continuing" *> loop urls 1857 -- Exactly one location header. 1858 [locBS] -> 1859 case decodeUtf8' locBS of 1860 Left e -> logDebug ("Invalid UTF8: " <> displayShow (locBS, e)) *> loop urls 1861 Right loc -> 1862 case extractVersion loc of 1863 Left s -> logDebug ("No version found: " <> displayShow (url, loc, s)) *> loop (loc:urls) 1864 -- We found a valid URL, let's use it! 1865 Right version -> do 1866 let hso = HaskellStackOrg 1867 { hsoUrl = loc 1868 , hsoVersion = version 1869 } 1870 logDebug $ "Downloading from haskellstack.org: " <> displayShow hso 1871 pure $ SRIHaskellStackOrg hso 1872 locs -> logDebug ("Multiple location headers found: " <> displayShow locs) *> loop urls 1873 loop urls0 1874downloadStackReleaseInfo morg mrepo mver = downloadStackReleaseInfoGithub morg mrepo mver 1875 1876-- | Same as above, but always uses Github 1877downloadStackReleaseInfoGithub 1878 :: (MonadIO m, MonadThrow m) 1879 => Maybe String -- Github org 1880 -> Maybe String -- Github repo 1881 -> Maybe String -- ^ optional version 1882 -> m StackReleaseInfo 1883downloadStackReleaseInfoGithub morg mrepo mver = liftIO $ do 1884 let org = fromMaybe "commercialhaskell" morg 1885 repo = fromMaybe "stack" mrepo 1886 let url = concat 1887 [ "https://api.github.com/repos/" 1888 , org 1889 , "/" 1890 , repo 1891 , "/releases/" 1892 , case mver of 1893 Nothing -> "latest" 1894 Just ver -> "tags/v" ++ ver 1895 ] 1896 req <- parseRequest url 1897 res <- httpJSON $ setGithubHeaders req 1898 let code = getResponseStatusCode res 1899 if code >= 200 && code < 300 1900 then return $ SRIGithub $ getResponseBody res 1901 else throwString $ "Could not get release information for Stack from: " ++ url 1902 1903preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m) 1904 => m [(Bool, String)] 1905preferredPlatforms = do 1906 Platform arch' os' <- view platformL 1907 (isWindows, os) <- 1908 case os' of 1909 Cabal.Linux -> return (False, "linux") 1910 Cabal.Windows -> return (True, "windows") 1911 Cabal.OSX -> return (False, "osx") 1912 Cabal.FreeBSD -> return (False, "freebsd") 1913 _ -> throwM $ stringException $ "Binary upgrade not yet supported on OS: " ++ show os' 1914 arch <- 1915 case arch' of 1916 I386 -> return "i386" 1917 X86_64 -> return "x86_64" 1918 Arm -> return "arm" 1919 _ -> throwM $ stringException $ "Binary upgrade not yet supported on arch: " ++ show arch' 1920 hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3") 1921 let suffixes 1922 | hasgmp4 = ["-static", "-gmp4", ""] 1923 | otherwise = ["-static", ""] 1924 return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes 1925 1926downloadStackExe 1927 :: HasConfig env 1928 => [(Bool, String)] -- ^ acceptable platforms 1929 -> StackReleaseInfo 1930 -> Path Abs Dir -- ^ destination directory 1931 -> Bool -- ^ perform PATH-aware checking, see #3232 1932 -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming 1933 -> RIO env () 1934downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do 1935 (isWindows, archiveURL) <- 1936 let loop [] = throwString $ "Unable to find binary Stack archive for platforms: " 1937 ++ unwords (map snd platforms0) 1938 loop ((isWindows, p'):ps) = do 1939 let p = T.pack p' 1940 logInfo $ "Querying for archive location for platform: " <> fromString p' 1941 case findArchive archiveInfo p of 1942 Just x -> return (isWindows, x) 1943 Nothing -> loop ps 1944 in loop platforms0 1945 1946 let (destFile, tmpFile) 1947 | isWindows = 1948 ( destDir </> relFileStackDotExe 1949 , destDir </> relFileStackDotTmpDotExe 1950 ) 1951 | otherwise = 1952 ( destDir </> relFileStack 1953 , destDir </> relFileStackDotTmp 1954 ) 1955 1956 logInfo $ "Downloading from: " <> RIO.display archiveURL 1957 1958 liftIO $ do 1959 case () of 1960 () 1961 | ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball tmpFile isWindows archiveURL 1962 | ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files" 1963 | otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL 1964 1965 logInfo "Download complete, testing executable" 1966 1967 platform <- view platformL 1968 1969 -- We need to call getExecutablePath before we overwrite the 1970 -- currently running binary: after that, Linux will append 1971 -- (deleted) to the filename. 1972 currExe <- liftIO getExecutablePath 1973 1974 liftIO $ do 1975 setFileExecutable (toFilePath tmpFile) 1976 1977 testExe tmpFile 1978 1979 case platform of 1980 Platform _ Cabal.Windows | FP.equalFilePath (toFilePath destFile) currExe -> do 1981 old <- parseAbsFile (toFilePath destFile ++ ".old") 1982 renameFile destFile old 1983 renameFile tmpFile destFile 1984 _ -> renameFile tmpFile destFile 1985 1986 destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir 1987 warnInstallSearchPathIssues destDir' ["stack"] 1988 1989 logInfo $ "New stack executable available at " <> fromString (toFilePath destFile) 1990 1991 when checkPath $ performPathChecking destFile currExe 1992 `catchAny` (logError . displayShow) 1993 where 1994 1995 findArchive (SRIGithub val) pattern = do 1996 Object top <- return val 1997 Array assets <- HashMap.lookup "assets" top 1998 getFirst $ fold $ fmap (First . findMatch pattern') assets 1999 where 2000 pattern' = mconcat ["-", pattern, "."] 2001 2002 findMatch pattern'' (Object o) = do 2003 String name <- HashMap.lookup "name" o 2004 guard $ not $ ".asc" `T.isSuffixOf` name 2005 guard $ pattern'' `T.isInfixOf` name 2006 String url <- HashMap.lookup "browser_download_url" o 2007 Just url 2008 findMatch _ _ = Nothing 2009 findArchive (SRIHaskellStackOrg hso) _ = pure $ hsoUrl hso 2010 2011 handleTarball :: Path Abs File -> Bool -> T.Text -> IO () 2012 handleTarball tmpFile isWindows url = do 2013 req <- fmap setGithubHeaders $ parseUrlThrow $ T.unpack url 2014 withResponse req $ \res -> do 2015 entries <- fmap (Tar.read . LBS.fromChunks) 2016 $ lazyConsume 2017 $ getResponseBody res .| ungzip 2018 let loop Tar.Done = error $ concat 2019 [ "Stack executable " 2020 , show exeName 2021 , " not found in archive from " 2022 , T.unpack url 2023 ] 2024 loop (Tar.Fail e) = throwM e 2025 loop (Tar.Next e es) = 2026 case FP.splitPath (Tar.entryPath e) of 2027 -- Ignore the first component, see: https://github.com/commercialhaskell/stack/issues/5288 2028 [_ignored, name] | name == exeName -> do 2029 case Tar.entryContent e of 2030 Tar.NormalFile lbs _ -> do 2031 ensureDir destDir 2032 LBS.writeFile (toFilePath tmpFile) lbs 2033 _ -> error $ concat 2034 [ "Invalid file type for tar entry named " 2035 , Tar.entryPath e 2036 , " downloaded from " 2037 , T.unpack url 2038 ] 2039 _ -> loop es 2040 loop entries 2041 where 2042 exeName 2043 | isWindows = "stack.exe" 2044 | otherwise = "stack" 2045 2046-- | Ensure that the Stack executable download is in the same location 2047-- as the currently running executable. See: 2048-- https://github.com/commercialhaskell/stack/issues/3232 2049performPathChecking 2050 :: HasConfig env 2051 => Path Abs File -- ^ location of the newly downloaded file 2052 -> String -- ^ currently running executable 2053 -> RIO env () 2054performPathChecking newFile executablePath = do 2055 executablePath' <- parseAbsFile executablePath 2056 unless (toFilePath newFile == executablePath) $ do 2057 logInfo $ "Also copying stack executable to " <> fromString executablePath 2058 tmpFile <- parseAbsFile $ executablePath ++ ".tmp" 2059 eres <- tryIO $ do 2060 liftIO $ copyFile newFile tmpFile 2061 setFileExecutable (toFilePath tmpFile) 2062 liftIO $ renameFile tmpFile executablePath' 2063 logInfo "Stack executable copied successfully!" 2064 case eres of 2065 Right () -> return () 2066 Left e 2067 | isPermissionError e -> do 2068 logWarn $ "Permission error when trying to copy: " <> displayShow e 2069 logWarn "Should I try to perform the file copy using sudo? This may fail" 2070 toSudo <- promptBool "Try using sudo? (y/n) " 2071 when toSudo $ do 2072 let run cmd args = do 2073 ec <- proc cmd args runProcess 2074 when (ec /= ExitSuccess) $ error $ concat 2075 [ "Process exited with " 2076 , show ec 2077 , ": " 2078 , unwords (cmd:args) 2079 ] 2080 commands = 2081 [ ("sudo", 2082 [ "cp" 2083 , toFilePath newFile 2084 , toFilePath tmpFile 2085 ]) 2086 , ("sudo", 2087 [ "mv" 2088 , toFilePath tmpFile 2089 , executablePath 2090 ]) 2091 ] 2092 logInfo "Going to run the following commands:" 2093 logInfo "" 2094 forM_ commands $ \(cmd, args) -> 2095 logInfo $ "- " <> mconcat (intersperse " " (fromString <$> (cmd:args))) 2096 mapM_ (uncurry run) commands 2097 logInfo "" 2098 logInfo "sudo file copy worked!" 2099 | otherwise -> throwM e 2100 2101getDownloadVersion :: StackReleaseInfo -> Maybe Version 2102getDownloadVersion (SRIGithub val) = do 2103 Object o <- Just val 2104 String rawName <- HashMap.lookup "name" o 2105 -- drop the "v" at the beginning of the name 2106 parseVersion $ T.unpack (T.drop 1 rawName) 2107getDownloadVersion (SRIHaskellStackOrg hso) = Just $ hsoVersion hso 2108