{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ViewPatterns        #-}

module Stack.Setup
  ( setupEnv
  , ensureCompilerAndMsys
  , ensureDockerStackExe
  , SetupOpts (..)
  , defaultSetupInfoYaml
  , withNewLocalBuildTargets

  -- * Stack binary download
  , StackReleaseInfo
  , getDownloadVersion
  , stackVersion
  , preferredPlatforms
  , downloadStackReleaseInfo
  , downloadStackExe
  ) where

import qualified Codec.Archive.Tar as Tar
import           Conduit
                   ( ConduitT, await, concatMapMC, filterCE, foldMC, yield )
import           Control.Applicative ( empty )
import           Crypto.Hash ( SHA1 (..), SHA256 (..) )
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.Binary as CB
import           Data.Conduit.Lazy ( lazyConsume )
import qualified Data.Conduit.List as CL
import           Data.Conduit.Process.Typed ( createSource )
import           Data.Conduit.Zlib ( ungzip )
import           Data.List.Split ( splitOn )
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Encoding.Error as T
import qualified Data.Yaml as Yaml
import           Distribution.System ( Arch (..), OS, Platform (..) )
import qualified Distribution.System as Cabal
import           Distribution.Text ( simpleParse )
import           Distribution.Types.PackageName ( mkPackageName )
import           Distribution.Version ( mkVersion )
import           Network.HTTP.Client ( redirectCount )
import           Network.HTTP.StackClient
                   ( CheckHexDigest (..), HashCheck (..), getResponseBody
                   , getResponseStatusCode, httpLbs, httpJSON
                   , mkDownloadRequest, parseRequest, parseUrlThrow
                   , setGitHubHeaders, setHashChecks, setLengthCheck
                   , verifiedDownloadWithProgress, withResponse
                   , setRequestMethod
                   )
import           Network.HTTP.Simple ( getResponseHeader )
import           Pantry.Internal.AesonExtended
                   ( Value (..), WithJSONWarnings (..), logJSONWarnings )
import           Path
                   ( (</>), dirname, filename, parent, parseAbsDir, parseAbsFile
                   , parseRelDir, parseRelFile, toFilePath
                   )
import           Path.CheckInstall ( warnInstallSearchPathIssues )
import           Path.Extended ( fileExtension )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO hiding ( findExecutable, withSystemTempDir )
import           RIO.List
                   ( headMaybe, intercalate, intersperse, isPrefixOf
                   , maximumByMaybe, sort, sortBy, stripPrefix )
import           RIO.Process
                   ( EnvVars, HasProcessContext (..), ProcessContext
                   , augmentPath, augmentPathMap, doesExecutableExist, envVarsL
                   , exeSearchPathL, getStdout, mkProcessContext, modifyEnvVars
                   , proc, readProcess_, readProcessStdout, runProcess
                   , runProcess_, setStdout, waitExitCode, withModifyEnvVars
                   , withProcessWait, withWorkingDir, workingDirL
                   )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Build.Source ( hashSourceMapData, loadSourceMap )
import           Stack.Build.Target ( NeedTargets (..), parseTargets )
import           Stack.Constants
import           Stack.Constants.Config ( distRelativeDir )
import           Stack.GhcPkg
                   ( createDatabase, getGlobalDB, ghcPkgPathEnvVar
                   , mkGhcPackagePath )
import           Stack.Prelude
import           Stack.SourceMap
import           Stack.Setup.Installed
                   ( Tool (..), extraDirs, filterTools, getCompilerVersion
                   , installDir, listInstalled, markInstalled, tempInstallDir
                   , toolString, unmarkInstalled
                   )
import           Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )
import           Stack.Types.Build
import           Stack.Types.Compiler
import           Stack.Types.CompilerBuild
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.SourceMap
import           Stack.Types.Version
import qualified System.Directory as D
import           System.Environment ( getExecutablePath, lookupEnv )
import           System.IO.Error ( isPermissionError )
import           System.FilePath ( searchPathSeparator )
import qualified System.FilePath as FP
import           System.Permissions ( setFileExecutable )
import           System.Uname ( getRelease )

-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Setup" module
data SetupException
    = UnsupportedSetupCombo OS Arch
    | MissingDependencies [String]
    | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)
    | UnknownOSKey Text
    | GHCSanityCheckCompileFailed SomeException (Path Abs File)
    | WantedMustBeGHC
    | RequireCustomGHCVariant
    | ProblemWhileDecompressing (Path Abs File)
    | SetupInfoMissingSevenz
    | DockerStackExeNotFound Version Text
    | UnsupportedSetupConfiguration
    | InvalidGhcAt (Path Abs File) SomeException
    | MSYS2NotFound Text
    | UnwantedCompilerVersion
    | UnwantedArchitecture
    | SandboxedCompilerNotFound
    | CompilerNotFound [String]
    | GHCInfoNotValidUTF8 UnicodeException
    | GHCInfoNotListOfPairs
    | GHCInfoMissingGlobalPackageDB
    | GHCInfoMissingTargetPlatform
    | GHCInfoTargetPlatformInvalid String
    | CabalNotFound (Path Abs File)
    | HadrianScriptNotFound
    | URLInvalid String
    | UnknownArchiveExtension String
    | Unsupported7z
    | TarballInvalid String
    | TarballFileInvalid String (Path Abs File)
    | UnknownArchiveStructure (Path Abs File)
    | StackReleaseInfoNotFound String
    | StackBinaryArchiveNotFound [String]
    | WorkingDirectoryInvalidBug
    | HadrianBindistNotFound
    | DownloadAndInstallCompilerError
    | StackBinaryArchiveZipUnsupportedBug
    | StackBinaryArchiveUnsupported Text
    | StackBinaryNotInArchive String Text
    | FileTypeInArchiveInvalid Tar.Entry Text
    | BinaryUpgradeOnOSUnsupported Cabal.OS
    | BinaryUpgradeOnArchUnsupported Cabal.Arch
    | ExistingMSYS2NotDeleted (Path Abs Dir) IOException
    deriving (Show, Typeable)

instance Exception SetupException where
    displayException (UnsupportedSetupCombo os arch) = concat
        [ "Error: [S-1852]\n"
        , "I don't know how to install GHC for "
        , show (os, arch)
        , ", please install manually"
        ]
    displayException (MissingDependencies tools) = concat
        [ "Error: [S-2126]\n"
        , "The following executables are missing and must be installed: "
        , intercalate ", " tools
        ]
    displayException (UnknownCompilerVersion oskeys wanted known) = concat
        [ "Error: [S-9443]\n"
        , "No setup information found for "
        , T.unpack $ utf8BuilderToText $ display wanted
        , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"
        , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))
        , "'.\nSupported versions: "
        , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))
        ]
    displayException (UnknownOSKey oskey) = concat
        [ "Error: [S-6810]\n"
        , "Unable to find installation URLs for OS key: "
        , T.unpack oskey
        ]
    displayException (GHCSanityCheckCompileFailed e ghc) = concat
        [ "Error: [S-5159]\n"
        , "The GHC located at "
        , toFilePath ghc
        , " failed to compile a sanity check. Please see:\n\n"
        , "    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"
        , "for more information. Exception was:\n"
        , displayException e
        ]
    displayException WantedMustBeGHC =
        "Error: [S-9030]\n"
        ++ "The wanted compiler must be GHC."
    displayException RequireCustomGHCVariant =
        "Error: [S-8948]\n"
        ++ "A custom '--ghc-variant' must be specified to use '--ghc-bindist'."
    displayException (ProblemWhileDecompressing archive) = concat
        [ "Error: [S-2905]\n"
        , "Problem while decompressing "
        , toFilePath archive
        ]
    displayException SetupInfoMissingSevenz =
        "Error: [S-9561]\n"
        ++ "SetupInfo missing Sevenz EXE/DLL."
    displayException (DockerStackExeNotFound stackVersion' osKey) = concat
        [ "Error: [S-1457]\n"
        , stackProgName
        , "-"
        , versionString stackVersion'
        , " executable not found for "
        , T.unpack osKey
        , "\nUse the '"
        , T.unpack dockerStackExeArgName
        , "' option to specify a location."]
    displayException UnsupportedSetupConfiguration =
        "Error: [S-7748]\n"
        ++ "Stack does not know how to install GHC on your system \
           \configuration, please install manually."
    displayException (InvalidGhcAt compiler e) = concat
        [ "Error: [S-2476]\n"
        , "Found an invalid compiler at "
        , show (toFilePath compiler)
        , ": "
        , displayException e
        ]
    displayException (MSYS2NotFound osKey) = concat
        [ "Error: [S-5308]\n"
        , "MSYS2 not found for "
        , T.unpack osKey
        ]
    displayException UnwantedCompilerVersion =
        "Error: [S-5127]\n"
        ++ "Not the compiler version we want."
    displayException UnwantedArchitecture =
        "Error: [S-1540]\n"
        ++ "Not the architecture we want."
    displayException SandboxedCompilerNotFound =
        "Error: [S-9953]\n"
        ++ "Could not find sandboxed compiler."
    displayException (CompilerNotFound toTry) = concat
        [ "Error: [S-4764]\n"
        , "Could not find any of: "
        , show toTry
        ]
    displayException (GHCInfoNotValidUTF8 e) = concat
        [ "Error: [S-8668]\n"
        , "GHC info is not valid UTF-8: "
        , displayException e
        ]
    displayException GHCInfoNotListOfPairs =
        "Error: [S-4878]\n"
        ++ "GHC info does not parse as a list of pairs."
    displayException GHCInfoMissingGlobalPackageDB =
        "Error: [S-2965]\n"
        ++ "Key 'Global Package DB' not found in GHC info."
    displayException GHCInfoMissingTargetPlatform =
        "Error: [S-5219]\n"
        ++ "Key 'Target platform' not found in GHC info."
    displayException (GHCInfoTargetPlatformInvalid targetPlatform) = concat
        [ "Error: [S-8299]\n"
        , "Invalid target platform in GHC info: "
        , targetPlatform
        ]
    displayException (CabalNotFound compiler) = concat
        [ "Error: [S-2574]\n"
        , "Cabal library not found in global package database for "
        , toFilePath compiler
        ]
    displayException HadrianScriptNotFound =
        "Error: [S-1128]\n"
        ++ "No Hadrian build script found."
    displayException (URLInvalid url) = concat
         [ "Error: [S-1906]\n"
         , "`url` must be either an HTTP URL or a file path: "
         , url
         ]
    displayException (UnknownArchiveExtension url) = concat
         [ "Error: [S-1648]\n"
         , "Unknown extension for url: "
         , url
         ]
    displayException Unsupported7z =
        "Error: [S-4509]\n"
        ++ "Don't know how to deal with .7z files on non-Windows."
    displayException (TarballInvalid name) = concat
        [ "Error: [S-3158]\n"
        , name
        , " must be a tarball file."
        ]
    displayException (TarballFileInvalid name archiveFile) = concat
        [ "Error: [S-5252]\n"
        , "Invalid "
        , name
        , " filename: "
        , show archiveFile
        ]
    displayException (UnknownArchiveStructure archiveFile) = concat
        [ "Error: [S-1827]\n"
        , "Expected a single directory within unpacked "
        , toFilePath archiveFile
        ]
    displayException (StackReleaseInfoNotFound url) = concat
        [ "Error: [S-9476]\n"
        , "Could not get release information for Stack from: "
        , url
        ]
    displayException (StackBinaryArchiveNotFound platforms) = concat
        [ "Error: [S-4461]\n"
        , "Unable to find binary Stack archive for platforms: "
        , unwords platforms
        ]
    displayException WorkingDirectoryInvalidBug = bugReport "[S-2076]"
        "Invalid working directory."
    displayException HadrianBindistNotFound =
        "Error: [S-6617]\n"
        ++ "Can't find Hadrian-generated binary distribution."
    displayException DownloadAndInstallCompilerError =
        "Error: [S-7227]\n"
        ++ "'downloadAndInstallCompiler' should not be reached with ghc-git."
    displayException StackBinaryArchiveZipUnsupportedBug = bugReport "[S-3967]"
        "FIXME: Handle zip files."
    displayException (StackBinaryArchiveUnsupported archiveURL) = concat
        [ "Error: [S-6636]\n"
        , "Unknown archive format for Stack archive: "
        , T.unpack archiveURL
        ]
    displayException (StackBinaryNotInArchive exeName url) = concat
        [ "Error: [S-7871]\n"
        , "Stack executable "
        , exeName
        , " not found in archive from "
        , T.unpack url
        ]
    displayException (FileTypeInArchiveInvalid e url) = concat
        [ "Error: [S-5046]\n"
        , "Invalid file type for tar entry named "
        , Tar.entryPath e
        , " downloaded from "
        , T.unpack url
        ]
    displayException (BinaryUpgradeOnOSUnsupported os) = concat
        [ "Error: [S-4132]\n"
        , "Binary upgrade not yet supported on OS: "
        , show os
        ]
    displayException (BinaryUpgradeOnArchUnsupported arch) = concat
        [ "Error: [S-3249]\n"
        , "Binary upgrade not yet supported on arch: "
        , show arch
        ]
    displayException (ExistingMSYS2NotDeleted destDir e) = concat
        [ "Error: [S-4230]\n"
        , "Could not delete existing MSYS2 directory: "
        , toFilePath destDir
        , "\n"
        , displayException e
        ]

-- | Type representing \'pretty\' exceptions thrown by functions exported by the
-- "Stack.Setup" module
data SetupPrettyException
    = GHCInstallFailed SomeException String String [String] (Path Abs Dir)
          (Path Abs Dir) (Path Abs Dir)
    deriving (Show, Typeable)

instance Pretty SetupPrettyException where
    pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
         "[S-7441]"
      <> line
      <> string (displayException ex)
      <> line
      <> hang 2 (  flow "Error encountered while" <+> fromString step <+> flow "GHC with"
                <> line
                <> style Shell (fromString (unwords (cmd : args)))
                <> line
                -- TODO: Figure out how to insert \ in the appropriate spots
                -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
                <> flow "run in" <+> pretty wd
                )
      <> blankLine
      <> flow "The following directories may now contain files, but won't be \
              \used by Stack:"
      <> line
      <> "  -" <+> pretty tempDir
      <> line
      <> "  -" <+> pretty destDir
      <> blankLine
      <> flow "For more information consider rerunning with --verbose flag"
      <> line

instance Exception SetupPrettyException

-- | Type representing exceptions thrown by 'performPathChecking'
data PerformPathCheckingException
    = ProcessExited ExitCode String [String]
    deriving (Show, Typeable)

instance Exception PerformPathCheckingException where
    displayException (ProcessExited ec cmd args) = concat
        [ "Error: [S-1991]\n"
        , "Process exited with "
        , displayException ec
        , ": "
        , unwords (cmd:args)
        ]

-- | Default location of the stack-setup.yaml file
defaultSetupInfoYaml :: String
defaultSetupInfoYaml =
    "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"

data SetupOpts = SetupOpts
    { soptsInstallIfMissing :: !Bool
    , soptsUseSystem :: !Bool
    -- ^ Should we use a system compiler installation, if available?
    , soptsWantedCompiler :: !WantedCompiler
    , soptsCompilerCheck :: !VersionCheck
    , soptsStackYaml :: !(Maybe (Path Abs File))
    -- ^ If we got the desired GHC version from that file
    , soptsForceReinstall :: !Bool
    , soptsSanityCheck :: !Bool
    -- ^ Run a sanity check on the selected GHC
    , soptsSkipGhcCheck :: !Bool
    -- ^ Don't check for a compatible GHC version/architecture
    , soptsSkipMsys :: !Bool
    -- ^ Do not use a custom msys installation on Windows
    , soptsResolveMissingGHC :: !(Maybe Text)
    -- ^ Message shown to user for how to resolve the missing GHC
    , soptsGHCBindistURL :: !(Maybe String)
    -- ^ Alternate GHC binary distribution (requires custom GHCVariant)
    }
    deriving Show
-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too
setupEnv :: NeedTargets
         -> BuildOptsCLI
         -> Maybe Text -- ^ Message to give user when necessary GHC is not available
         -> RIO BuildConfig EnvConfig
setupEnv needTargets boptsCLI mResolveMissingGHC = do
    config <- view configL
    bc <- view buildConfigL
    let stackYaml = bcStackYaml bc
    platform <- view platformL
    wcVersion <- view wantedCompilerVersionL
    wanted <- view wantedCompilerVersionL
    actual <- either throwIO pure $ wantedToActual wanted
    let wc = actual^.whichCompilerL
    let sopts = SetupOpts
            { soptsInstallIfMissing = configInstallGHC config
            , soptsUseSystem = configSystemGHC config
            , soptsWantedCompiler = wcVersion
            , soptsCompilerCheck = configCompilerCheck config
            , soptsStackYaml = Just stackYaml
            , soptsForceReinstall = False
            , soptsSanityCheck = False
            , soptsSkipGhcCheck = configSkipGHCCheck config
            , soptsSkipMsys = configSkipMsys config
            , soptsResolveMissingGHC = mResolveMissingGHC
            , soptsGHCBindistURL = Nothing
            }

    (compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts
    let compilerVer = cpCompilerVersion compilerPaths

    -- Modify the initial environment to include the GHC path, if a local GHC
    -- is being used
    menv0 <- view processContextL
    env <- either throwM (pure . removeHaskellEnvVars)
               $ augmentPathMap
                    (map toFilePath $ edBins ghcBin)
                    (view envVarsL menv0)
    menv <- mkProcessContext env

    logDebug "Resolving package entries"

    (sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do
      smActual <- actualFromGhc (bcSMWanted bc) compilerVer
      let actualPkgs = Map.keysSet (smaDeps smActual) <>
                       Map.keysSet (smaProject smActual)
          prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
          haddockDeps = shouldHaddockDeps (configBuild config)
      targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
      sourceMap <- loadSourceMap targets boptsCLI smActual
      sourceMapHash <- hashSourceMapData boptsCLI sourceMap
      pure (sourceMap, sourceMapHash)

    let envConfig0 = EnvConfig
            { envConfigBuildConfig = bc
            , envConfigBuildOptsCLI = boptsCLI
            , envConfigSourceMap = sourceMap
            , envConfigSourceMapHash = sourceMapHash
            , envConfigCompilerPaths = compilerPaths
            }

    -- extra installation bin directories
    mkDirs <- runRIO envConfig0 extraBinDirs
    let mpath = Map.lookup "PATH" env
    depsPath <- either throwM pure $ augmentPath (toFilePath <$> mkDirs False) mpath
    localsPath <- either throwM pure $ augmentPath (toFilePath <$> mkDirs True) mpath

    deps <- runRIO envConfig0 packageDatabaseDeps
    runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps
    localdb <- runRIO envConfig0 packageDatabaseLocal
    runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) localdb
    extras <- runReaderT packageDatabaseExtra envConfig0
    let mkGPP locals = mkGhcPackagePath locals localdb deps extras $ cpGlobalDB compilerPaths

    distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath

    executablePath <- liftIO getExecutablePath

    utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer

    mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS"

    envRef <- liftIO $ newIORef Map.empty
    let getProcessContext' es = do
            m <- readIORef envRef
            case Map.lookup es m of
                Just eo -> pure eo
                Nothing -> do
                    eo <- mkProcessContext
                        $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)
                        $ (if esIncludeGhcPackagePath es
                                then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es))
                                else id)

                        $ (if esStackExe es
                                then Map.insert "STACK_EXE" (T.pack executablePath)
                                else id)

                        $ (if esLocaleUtf8 es
                                then Map.union utf8EnvVars
                                else id)

                        $ case (soptsSkipMsys sopts, platform) of
                            (False, Platform Cabal.I386   Cabal.Windows)
                                -> Map.insert "MSYSTEM" "MINGW32"
                            (False, Platform Cabal.X86_64 Cabal.Windows)
                                -> Map.insert "MSYSTEM" "MINGW64"
                            _   -> id

                        -- See https://github.com/commercialhaskell/stack/issues/3444
                        $ case (esKeepGhcRts es, mGhcRtsEnvVar) of
                            (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts)
                            _ -> id

                        -- For reasoning and duplication, see:
                        -- https://github.com/commercialhaskell/stack/issues/70
                        $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps)
                        $ Map.insert "HASKELL_PACKAGE_SANDBOXES"
                            (T.pack $ if esIncludeLocals es
                                then intercalate [searchPathSeparator]
                                        [ toFilePathNoTrailingSep localdb
                                        , toFilePathNoTrailingSep deps
                                        , ""
                                        ]
                                else intercalate [searchPathSeparator]
                                        [ toFilePathNoTrailingSep deps
                                        , ""
                                        ])
                        $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir)

                          -- Make sure that any .ghc.environment files
                          -- are ignored, since we're setting up our
                          -- own package databases. See
                          -- https://github.com/commercialhaskell/stack/issues/4706
                        $ (case cpCompilerVersion compilerPaths of
                             ACGhc version | version >= mkVersion [8, 4, 4] ->
                               Map.insert "GHC_ENVIRONMENT" "-"
                             _ -> id)

                          env

                    () <- atomicModifyIORef envRef $ \m' ->
                        (Map.insert es eo m', ())
                    pure eo

    envOverride <- liftIO $ getProcessContext' minimalEnvSettings
    pure EnvConfig
        { envConfigBuildConfig = bc
            { bcConfig = addIncludeLib ghcBin
                       $ set processContextL envOverride
                         (view configL bc)
                { configProcessContextSettings = getProcessContext'
                }
            }
        , envConfigBuildOptsCLI = boptsCLI
        , envConfigSourceMap = sourceMap
        , envConfigSourceMapHash = sourceMapHash
        , envConfigCompilerPaths = compilerPaths
        }

-- | A modified env which we know has an installed compiler on the PATH.
data WithGHC env = WithGHC !CompilerPaths !env

insideL :: Lens' (WithGHC env) env
insideL = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp)

instance HasLogFunc env => HasLogFunc (WithGHC env) where
  logFuncL = insideL.logFuncL
instance HasRunner env => HasRunner (WithGHC env) where
  runnerL = insideL.runnerL
instance HasProcessContext env => HasProcessContext (WithGHC env) where
  processContextL = insideL.processContextL
instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where
  stylesUpdateL = insideL.stylesUpdateL
instance HasTerm env => HasTerm (WithGHC env) where
  useColorL = insideL.useColorL
  termWidthL = insideL.termWidthL
instance HasPantryConfig env => HasPantryConfig (WithGHC env) where
  pantryConfigL = insideL.pantryConfigL
instance HasConfig env => HasPlatform (WithGHC env)
instance HasConfig env => HasGHCVariant (WithGHC env)
instance HasConfig env => HasConfig (WithGHC env) where
  configL = insideL.configL
instance HasBuildConfig env => HasBuildConfig (WithGHC env) where
  buildConfigL = insideL.buildConfigL
instance HasCompiler (WithGHC env) where
  compilerPathsL = to (\(WithGHC cp _) -> cp)

-- | Set up a modified environment which includes the modified PATH
-- that GHC can be found on. This is needed for looking up global
-- package information and ghc fingerprint (result from 'ghc --info').
runWithGHC :: HasConfig env => ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC pc cp inner = do
  env <- ask
  let envg
        = WithGHC cp $
          set envOverrideSettingsL (\_ -> pure pc) $
          set processContextL pc env
  runRIO envg inner

-- | special helper for GHCJS which needs an updated source map
-- only project dependencies should get included otherwise source map hash will
-- get changed and EnvConfig will become inconsistent
rebuildEnv :: EnvConfig
    -> NeedTargets
    -> Bool
    -> BuildOptsCLI
    -> RIO env EnvConfig
rebuildEnv envConfig needTargets haddockDeps boptsCLI = do
    let bc = envConfigBuildConfig envConfig
        cp = envConfigCompilerPaths envConfig
        compilerVer = smCompiler $ envConfigSourceMap envConfig
    runRIO (WithGHC cp bc) $ do
        smActual <- actualFromGhc (bcSMWanted bc) compilerVer
        let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual)
            prunedActual = smActual {
              smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs
              }
        targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
        sourceMap <- loadSourceMap targets boptsCLI smActual
        pure $
            envConfig
            {envConfigSourceMap = sourceMap, envConfigBuildOptsCLI = boptsCLI}

-- | Some commands (script, ghci and exec) set targets dynamically
-- see also the note about only local targets for rebuildEnv
withNewLocalBuildTargets :: HasEnvConfig  env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets targets f = do
    envConfig <- view $ envConfigL
    haddockDeps <- view $ configL.to configBuild.to shouldHaddockDeps
    let boptsCLI = envConfigBuildOptsCLI envConfig
    envConfig' <- rebuildEnv envConfig NeedTargets haddockDeps $
                  boptsCLI {boptsCLITargets = targets}
    local (set envConfigL envConfig') f

-- | Add the include and lib paths to the given Config
addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib (ExtraDirs _bins includes libs) config = config
    { configExtraIncludeDirs =
        configExtraIncludeDirs config ++
        map toFilePathNoTrailingSep includes
    , configExtraLibDirs =
        configExtraLibDirs config ++
        map toFilePathNoTrailingSep libs
    }

-- | Ensure both the compiler and the msys toolchain are installed and
-- provide the PATHs to add if necessary
ensureCompilerAndMsys
  :: (HasBuildConfig env, HasGHCVariant env)
  => SetupOpts
  -> RIO env (CompilerPaths, ExtraDirs)
ensureCompilerAndMsys sopts = do
  getSetupInfo' <- memoizeRef getSetupInfo
  mmsys2Tool <- ensureMsys sopts getSetupInfo'
  msysPaths <- maybe (pure Nothing) (fmap Just . extraDirs) mmsys2Tool

  actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts
  didWarn <- warnUnsupportedCompiler $ getGhcVersion actual

  (cp, ghcPaths) <- ensureCompiler sopts getSetupInfo'

  warnUnsupportedCompilerCabal cp didWarn

  let paths = maybe ghcPaths (ghcPaths <>) msysPaths
  pure (cp, paths)

-- | See <https://github.com/commercialhaskell/stack/issues/4246>
warnUnsupportedCompiler :: HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler ghcVersion = do
  if
    | ghcVersion < mkVersion [7, 8] -> do
        logWarn $
          "Stack will almost certainly fail with GHC below version 7.8, requested " <>
          fromString (versionString ghcVersion)
        logWarn "Valiantly attempting to run anyway, but I know this is doomed"
        logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"
        logWarn ""
        pure True
    | ghcVersion >= mkVersion [9, 5] -> do
        logWarn $
          "Stack has not been tested with GHC versions above 9.4, and using " <>
          fromString (versionString ghcVersion) <>
          ", this may fail"
        pure True
    | otherwise -> do
        logDebug "Asking for a supported GHC version"
        pure False

-- | See <https://github.com/commercialhaskell/stack/issues/4246>
warnUnsupportedCompilerCabal
  :: HasLogFunc env
  => CompilerPaths
  -> Bool -- ^ already warned about GHC?
  -> RIO env ()
warnUnsupportedCompilerCabal cp didWarn = do
  unless didWarn $ void $ warnUnsupportedCompiler $ getGhcVersion $ cpCompilerVersion cp
  let cabalVersion = cpCabalVersion cp

  if
    | cabalVersion < mkVersion [1, 19, 2] -> do
        logWarn $ "Stack no longer supports Cabal versions below 1.19.2,"
        logWarn $ "but version " <> fromString (versionString cabalVersion) <> " was found."
        logWarn "This invocation will most likely fail."
        logWarn "To fix this, either use an older version of Stack or a newer resolver"
        logWarn "Acceptable resolvers: lts-3.0/nightly-2015-05-05 or later"
    | cabalVersion >= mkVersion [3, 9] ->
        logWarn $
          "Stack has not been tested with Cabal versions above 3.8, but version " <>
          fromString (versionString cabalVersion) <>
          " was found, this may fail"
    | otherwise -> pure ()

-- | Ensure that the msys toolchain is installed if necessary and
-- provide the PATHs to add if necessary
ensureMsys
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (Maybe Tool)
ensureMsys sopts getSetupInfo' = do
  platform <- view platformL
  localPrograms <- view $ configL.to configLocalPrograms
  installed <- listInstalled localPrograms

  case platform of
      Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
          case getInstalledTool installed (mkPackageName "msys2") (const True) of
              Just tool -> pure (Just tool)
              Nothing
                  | soptsInstallIfMissing sopts -> do
                      si <- runMemoized getSetupInfo'
                      osKey <- getOSKey platform
                      config <- view configL
                      VersionedDownloadInfo version info <-
                          case Map.lookup osKey $ siMsys2 si of
                              Just x -> pure x
                              Nothing -> throwIO $ MSYS2NotFound osKey
                      let tool = Tool (PackageIdentifier (mkPackageName "msys2") version)
                      Just <$> downloadAndInstallTool (configLocalPrograms config) info tool (installMsys2Windows si)
                  | otherwise -> do
                      logWarn "Continuing despite missing tool: msys2"
                      pure Nothing
      _ -> pure Nothing

installGhcBindist
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> [Tool]
  -> RIO env (Tool, CompilerBuild)
installGhcBindist sopts getSetupInfo' installed = do
    Platform expectedArch _ <- view platformL
    let wanted = soptsWantedCompiler sopts
        isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
    config <- view configL
    ghcVariant <- view ghcVariantL
    wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
    possibleCompilers <-
            case wc of
                Ghc -> do
                    ghcBuilds <- getGhcBuilds
                    forM ghcBuilds $ \ghcBuild -> do
                        ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
                        pure (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)
    let existingCompilers = concatMap
            (\(installedCompiler, compilerBuild) ->
                case (installedCompiler, soptsForceReinstall sopts) of
                    (Just tool, False) -> [(tool, compilerBuild)]
                    _ -> [])
            possibleCompilers
    logDebug $
      "Found already installed GHC builds: " <>
      mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))
    case existingCompilers of
        (tool, build_):_ -> pure (tool, build_)
        []
            | soptsInstallIfMissing sopts -> do
                si <- runMemoized getSetupInfo'
                downloadAndInstallPossibleCompilers
                    (map snd possibleCompilers)
                    si
                    (soptsWantedCompiler sopts)
                    (soptsCompilerCheck sopts)
                    (soptsGHCBindistURL sopts)
            | otherwise -> do
                let suggestion = fromMaybe
                        (mconcat
                             [ "To install the correct GHC into "
                             , T.pack (toFilePath (configLocalPrograms config))
                             , ", try running 'stack setup' or use the '--install-ghc' flag."
                             , " To use your system GHC installation, run \
                               \'stack config set system-ghc --global true', \
                               \or use the '--system-ghc' flag."
                             ])
                        (soptsResolveMissingGHC sopts)
                throwM $ CompilerVersionMismatch
                    Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem)
                    (soptsWantedCompiler sopts, expectedArch)
                    ghcVariant
                    (case possibleCompilers of
                        [] -> CompilerBuildStandard
                        (_, compilerBuild):_ -> compilerBuild)
                    (soptsCompilerCheck sopts)
                    (soptsStackYaml sopts)
                    suggestion

-- | Ensure compiler is installed, without worrying about msys
ensureCompiler
  :: forall env. (HasConfig env, HasBuildConfig env, HasGHCVariant env)
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (CompilerPaths, ExtraDirs)
ensureCompiler sopts getSetupInfo' = do
    let wanted = soptsWantedCompiler sopts
    wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted

    hook <- ghcInstallHook
    hookIsExecutable <- handleIO (\_ -> pure False) $ if osIsWindows
      then doesFileExist hook  -- can't really detect executable on windows, only file extension
      else executable <$> getPermissions hook

    Platform expectedArch _ <- view platformL

    let canUseCompiler cp
            | soptsSkipGhcCheck sopts = pure cp
            | not $ isWanted $ cpCompilerVersion cp = throwIO UnwantedCompilerVersion
            | cpArch cp /= expectedArch = throwIO UnwantedArchitecture
            | otherwise = pure cp
        isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)

    let checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths)
        checkCompiler compiler = do
          eres <- tryAny $ pathsFromCompiler wc CompilerBuildStandard False compiler >>= canUseCompiler
          case eres of
            Left e -> do
              logDebug $ "Not using compiler at " <> displayShow (toFilePath compiler) <> ": " <> displayShow e
              pure Nothing
            Right cp -> pure $ Just cp

    mcp <-
      if | soptsUseSystem sopts -> do
            logDebug "Getting system compiler version"
            runConduit $
              sourceSystemCompilers wanted .|
              concatMapMC checkCompiler .|
              await
         | hookIsExecutable -> do
          -- if the hook fails, we fall through to stacks sandboxed installation
            hookGHC <- runGHCInstallHook sopts hook
            maybe (pure Nothing) checkCompiler hookGHC
         | otherwise -> pure Nothing
    case mcp of
      Nothing -> ensureSandboxedCompiler sopts getSetupInfo'
      Just cp -> do
        let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] }
        pure (cp, paths)


-- | Runs @STACK_ROOT\/hooks\/ghc-install.sh@.
--
-- Reads and possibly validates the output of the process as the GHC
-- binary and returns it.
runGHCInstallHook
  :: HasBuildConfig env
  => SetupOpts
  -> Path Abs File
  -> RIO env (Maybe (Path Abs File))
runGHCInstallHook sopts hook = do
    logDebug "Getting hook installed compiler version"
    let wanted = soptsWantedCompiler sopts
    menv0 <- view processContextL
    menv <- mkProcessContext (Map.union (wantedCompilerToEnv wanted) $
      removeHaskellEnvVars (view envVarsL menv0))
    (exit, out) <- withProcessContext menv $ proc "sh" [toFilePath hook] readProcessStdout
    case exit of
      ExitSuccess -> do
        let ghcPath = stripNewline . TL.unpack . TL.decodeUtf8With T.lenientDecode $ out
        case parseAbsFile ghcPath of
          Just compiler -> do
            when (soptsSanityCheck sopts) $ sanityCheck compiler
            logDebug ("Using GHC compiler at: " <> fromString (toFilePath compiler))
            pure (Just compiler)
          Nothing -> do
            logWarn ("Path to GHC binary is not a valid path: " <> fromString ghcPath)
            pure Nothing
      ExitFailure i -> do
        logWarn ("GHC install hook exited with code: " <> fromString (show i))
        pure Nothing
 where
    wantedCompilerToEnv :: WantedCompiler -> EnvVars
    wantedCompilerToEnv (WCGhc ver) =
      Map.fromList [("HOOK_GHC_TYPE", "bindist")
                   ,("HOOK_GHC_VERSION", T.pack (versionString ver))
                   ]
    wantedCompilerToEnv (WCGhcGit commit flavor) =
      Map.fromList [("HOOK_GHC_TYPE", "git")
                   ,("HOOK_GHC_COMMIT", commit)
                   ,("HOOK_GHC_FLAVOR", flavor)
                   ,("HOOK_GHC_FLAVOUR", flavor)
                   ]
    wantedCompilerToEnv (WCGhcjs ghcjs_ver ghc_ver) =
      Map.fromList [("HOOK_GHC_TYPE", "ghcjs")
                   ,("HOOK_GHC_VERSION", T.pack (versionString ghc_ver))
                   ,("HOOK_GHCJS_VERSION", T.pack (versionString ghcjs_ver))
                   ]
    newlines :: [Char]
    newlines = ['\n', '\r']

    stripNewline :: String -> String
    stripNewline str = filter (flip notElem newlines) str


ensureSandboxedCompiler
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler sopts getSetupInfo' = do
    let wanted = soptsWantedCompiler sopts
    -- List installed tools
    config <- view configL
    let localPrograms = configLocalPrograms config
    installed <- listInstalled localPrograms
    logDebug $ "Installed tools: \n - " <> mconcat (intersperse "\n - " (map (fromString . toolString) installed))
    (compilerTool, compilerBuild) <-
      case soptsWantedCompiler sopts of
       -- shall we build GHC from source?
       WCGhcGit commitId flavour -> buildGhcFromSource getSetupInfo' installed  (configCompilerRepository config) commitId flavour
       _ -> installGhcBindist sopts getSetupInfo' installed
    paths <- extraDirs compilerTool

    wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
    menv0 <- view processContextL
    m <- either throwM pure
       $ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0)
    menv <- mkProcessContext (removeHaskellEnvVars m)

    names <-
      case wanted of
        WCGhc version -> pure ["ghc-" ++ versionString version, "ghc"]
        WCGhcGit{} -> pure ["ghc"]
        WCGhcjs{} -> throwIO GhcjsNotSupported

    -- Previously, we used findExecutable to locate these executables. This was
    -- actually somewhat sloppy, as it could discover executables outside of the
    -- sandbox. This led to a specific issue on Windows with GHC 9.0.1. See
    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20074. Instead, now, we look
    -- on the paths specified only.
    let loop [] = do
          logError $ "Looked for sandboxed compiler named one of: " <> displayShow names
          logError $ "Could not find it on the paths " <> displayShow (edBins paths)
          throwIO SandboxedCompilerNotFound
        loop (x:xs) = do
          res <- liftIO $ D.findExecutablesInDirectories (map toFilePath (edBins paths)) x
          case res of
            [] -> loop xs
            compiler:rest -> do
              unless (null rest) $ do
                logWarn "Found multiple candidate compilers:"
                for_ res $ \y -> logWarn $ "- " <> fromString y
                logWarn $ "This usually indicates a failed installation. Trying anyway with " <> fromString compiler
              parseAbsFile compiler
    compiler <- withProcessContext menv $ do
      compiler <- loop names

      -- Run this here to ensure that the sanity check uses the modified
      -- environment, otherwise we may infect GHC_PACKAGE_PATH and break sanity
      -- checks.
      when (soptsSanityCheck sopts) $ sanityCheck compiler

      pure compiler

    cp <- pathsFromCompiler wc compilerBuild True compiler
    pure (cp, paths)

pathsFromCompiler
  :: forall env. HasConfig env
  => WhichCompiler
  -> CompilerBuild
  -> Bool
  -> Path Abs File -- ^ executable filepath
  -> RIO env CompilerPaths
pathsFromCompiler wc compilerBuild isSandboxed compiler = withCache $ handleAny onErr $ do
    let dir = toFilePath $ parent compiler
        suffixNoVersion
          | osIsWindows = ".exe"
          | otherwise = ""
        msuffixWithVersion = do
          let prefix =
                case wc of
                  Ghc -> "ghc-"
          fmap ("-" ++) $ stripPrefix prefix $ toFilePath $ filename compiler
        suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion]
        findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
        findHelper getNames = do
          let toTry = [dir ++ name ++ suffix | suffix <- suffixes, name <- getNames wc]
              loop [] = throwIO $ CompilerNotFound toTry
              loop (guessedPath':rest) = do
                guessedPath <- parseAbsFile guessedPath'
                exists <- doesFileExist guessedPath
                if exists
                  then pure guessedPath
                  else loop rest
          logDebug $ "Looking for executable(s): " <> displayShow toTry
          loop toTry
    pkg <- fmap GhcPkgExe $ findHelper $ \case
                               Ghc -> ["ghc-pkg"]

    menv0 <- view processContextL
    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))

    interpreter <- findHelper $
                   \case
                      Ghc -> ["runghc"]
    haddock <- findHelper $
               \case
                  Ghc -> ["haddock", "haddock-ghc"]
    infobs <- proc (toFilePath compiler) ["--info"]
            $ fmap (toStrictBytes . fst) . readProcess_
    infotext <-
      case decodeUtf8' infobs of
        Left e -> throwIO $ GHCInfoNotValidUTF8 e
        Right info -> pure info
    infoPairs :: [(String, String)] <-
      case readMaybe $ T.unpack infotext of
        Nothing -> throwIO GHCInfoNotListOfPairs
        Just infoPairs -> pure infoPairs
    let infoMap = Map.fromList infoPairs

    eglobaldb <- tryAny $
      case Map.lookup "Global Package DB" infoMap of
        Nothing -> throwIO GHCInfoMissingGlobalPackageDB
        Just db -> parseAbsDir db

    arch <-
      case Map.lookup "Target platform" infoMap of
        Nothing -> throwIO GHCInfoMissingTargetPlatform
        Just targetPlatform ->
          case simpleParse $ takeWhile (/= '-') targetPlatform of
            Nothing -> throwIO $ GHCInfoTargetPlatformInvalid targetPlatform
            Just arch -> pure arch
    compilerVer <-
      case wc of
        Ghc ->
          case Map.lookup "Project version" infoMap of
            Nothing -> do
              logWarn "Key 'Project version' not found in GHC info"
              getCompilerVersion wc compiler
            Just versionString' -> ACGhc <$> parseVersionThrowing versionString'
    globaldb <-
      case eglobaldb of
        Left e -> do
          logWarn "Parsing global DB from GHC info failed"
          logWarn $ displayShow e
          logWarn "Asking ghc-pkg directly"
          withProcessContext menv $ getGlobalDB pkg
        Right x -> pure x

    globalDump <- withProcessContext menv $ globalsFromDump pkg
    cabalPkgVer <-
      case Map.lookup cabalPackageName globalDump of
        Nothing -> throwIO $ CabalNotFound compiler
        Just dp -> pure $ pkgVersion $ dpPackageIdent dp

    pure CompilerPaths
      { cpBuild = compilerBuild
      , cpArch = arch
      , cpSandboxed = isSandboxed
      , cpCompilerVersion = compilerVer
      , cpCompiler = compiler
      , cpPkg = pkg
      , cpInterpreter = interpreter
      , cpHaddock = haddock
      , cpCabalVersion = cabalPkgVer
      , cpGlobalDB = globaldb
      , cpGhcInfo = infobs
      , cpGlobalDump = globalDump
      }
  where
    onErr = throwIO . InvalidGhcAt compiler

    withCache inner = do
      eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed
      mres <-
        case eres of
          Left e -> do
            logWarn $ "Trouble loading CompilerPaths cache: " <> displayShow e
            pure Nothing
          Right x -> pure x
      case mres of
        Just cp -> cp <$ logDebug "Loaded compiler information from cache"
        Nothing -> do
          cp <- inner
          saveCompilerPaths cp `catchAny` \e ->
            logWarn ("Unable to save CompilerPaths cache: " <> displayShow e)
          pure cp

buildGhcFromSource :: forall env.
   ( HasTerm env
   , HasProcessContext env
   , HasBuildConfig env
   ) => Memoized SetupInfo -> [Tool] -> CompilerRepository -> Text -> Text
   -> RIO env (Tool, CompilerBuild)
buildGhcFromSource getSetupInfo' installed (CompilerRepository url) commitId flavour = do
   config <- view configL
   let compilerTool = ToolGhcGit commitId flavour

   -- detect when the correct GHC is already installed
   if compilerTool `elem` installed
     then pure (compilerTool,CompilerBuildStandard)
     else do
       -- clone the repository and execute the given commands
       withRepo (SimpleRepo url commitId RepoGit) $ do
         -- withRepo is guaranteed to set workingDirL, so let's get it
         mcwd <- traverse parseAbsDir =<< view workingDirL
         cwd <- maybe (throwIO WorkingDirectoryInvalidBug) pure mcwd
         threads <- view $ configL.to configJobs
         let
           hadrianArgs = fmap T.unpack
               [ "-c"                    -- run ./boot and ./configure
               , "-j" <> tshow threads   -- parallel build
               , "--flavour=" <> flavour -- selected flavour
               , "binary-dist"
               ]
           hadrianScripts
             | osIsWindows = hadrianScriptsWindows
             | otherwise   = hadrianScriptsPosix

         foundHadrianPaths <- filterM doesFileExist $ (cwd </>) <$> hadrianScripts
         hadrianPath <-
           maybe (throwIO HadrianScriptNotFound) pure $ listToMaybe foundHadrianPaths

         logSticky $ "Building GHC from source with `"
            <> display flavour
            <> "` flavour. It can take a long time (more than one hour)..."

         -- We need to provide an absolute path to the script since
         -- the process package only sets working directory _after_
         -- discovering the executable
         proc (toFilePath hadrianPath) hadrianArgs runProcess_

         -- find the bindist and install it
         bindistPath <- parseRelDir "_build/bindist"
         (_,files) <- listDir (cwd </> bindistPath)
         let
           isBindist p = do
             extension <- fileExtension (filename p)

             pure $ "ghc-" `isPrefixOf` (toFilePath (filename p))
                         && extension == ".xz"

         mbindist <- filterM isBindist files
         case mbindist of
           [bindist] -> do
               let bindist' = T.pack (toFilePath bindist)
                   dlinfo = DownloadInfo
                             { downloadInfoUrl           = bindist'
                               -- we can specify a filepath instead of a URL
                             , downloadInfoContentLength = Nothing
                             , downloadInfoSha1          = Nothing
                             , downloadInfoSha256        = Nothing
                             }
                   ghcdlinfo = GHCDownloadInfo mempty mempty dlinfo
                   installer
                      | osIsWindows = installGHCWindows
                      | otherwise   = installGHCPosix ghcdlinfo
               si <- runMemoized getSetupInfo'
               _ <- downloadAndInstallTool
                 (configLocalPrograms config)
                 dlinfo
                 compilerTool
                 (installer si)
               pure (compilerTool, CompilerBuildStandard)
           _ -> do
              forM_ files (logDebug . fromString . (" - " ++) . toFilePath)
              throwIO HadrianBindistNotFound

-- | Determine which GHC builds to use depending on which shared libraries are available
-- on the system.
getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]
getGhcBuilds = do

    config <- view configL
    case configGHCBuild config of
        Just ghcBuild -> pure [ghcBuild]
        Nothing -> determineGhcBuild
  where
    determineGhcBuild = do
        -- TODO: a more reliable, flexible, and data driven approach would be to actually download small
        -- "test" executables (from setup-info) that link to the same gmp/tinfo versions
        -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go
        -- something like this:
        --
        -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache
        -- if cached, then use that as suffix
        -- otherwise:
        --     download setup-info
        --     go through all with right prefix for os/version/variant
        --     first try "standard" (no extra suffix), then the rest
        --         download "compatibility check" exe if not already downloaded
        --         try running it
        --         if successful, then choose that
        --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version
        --
        -- Of course, could also try to make a static GHC bindist instead of all this rigamarole.

        platform <- view platformL
        case platform of
            Platform _ Cabal.Linux -> do
                -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well
                let sbinEnv m = Map.insert
                      "PATH"
                      ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))
                      m
                eldconfigOut
                  <- withModifyEnvVars sbinEnv
                   $ proc "ldconfig" ["-p"]
                   $ tryAny . fmap fst . readProcess_
                let firstWords = case eldconfigOut of
                        Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $
                            T.lines $ T.decodeUtf8With T.lenientDecode
                                    $ LBS.toStrict ldconfigOut
                        Left _ -> []
                    checkLib lib
                        | libT `elem` firstWords = do
                            logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output")
                            pure True
                        | osIsWindows =
                            -- Cannot parse /usr/lib on Windows
                            pure False
                        | otherwise = do
                        -- This is a workaround for the fact that libtinfo.so.x doesn't appear in
                        -- the 'ldconfig -p' output on Arch or Slackware even when it exists.
                        -- There doesn't seem to be an easy way to get the true list of directories
                        -- to scan for shared libs, but this works for our particular cases.
                            matches <- filterM (doesFileExist .(</> lib)) usrLibDirs
                            case matches of
                                [] -> logDebug ("Did not find shared library " <> libD)
                                    >> pure False
                                (path:_) -> logDebug ("Found shared library " <> libD
                                        <> " in " <> fromString (Path.toFilePath path))
                                    >> pure True
                      where
                        libT = T.pack (toFilePath lib)
                        libD = fromString (toFilePath lib)
                hastinfo5 <- checkLib relFileLibtinfoSo5
                hastinfo6 <- checkLib relFileLibtinfoSo6
                hasncurses6 <- checkLib relFileLibncurseswSo6
                hasgmp5 <- checkLib relFileLibgmpSo10
                hasgmp4 <- checkLib relFileLibgmpSo3
                let libComponents = concat
                        [ [["tinfo6"] | hastinfo6 && hasgmp5]
                        , [[] | hastinfo5 && hasgmp5]
                        , [["ncurses6"] | hasncurses6 && hasgmp5 ]
                        , [["gmp4"] | hasgmp4 ]
                        ]
                useBuilds $ map
                    (\c -> case c of
                        [] -> CompilerBuildStandard
                        _ -> CompilerBuildSpecialized (intercalate "-" c))
                    libComponents
            Platform _ Cabal.FreeBSD -> do
                let getMajorVer = readMaybe <=< headMaybe . (splitOn ".")
                majorVer <- getMajorVer <$> sysRelease
                if majorVer >= Just (12 :: Int) then
                  useBuilds [CompilerBuildSpecialized "ino64"]
                else
                  useBuilds [CompilerBuildStandard]
            Platform _ Cabal.OpenBSD -> do
                releaseStr <- mungeRelease <$> sysRelease
                useBuilds [CompilerBuildSpecialized releaseStr]
            _ -> useBuilds [CompilerBuildStandard]
    useBuilds builds = do
        logDebug $
          "Potential GHC builds: " <>
          mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))
        pure builds

-- | Encode an OpenBSD version (like "6.1") into a valid argument for
-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed
-- with "r".
-- The result r must be such that "ghc-" ++ r is a valid package name,
-- as recognized by parsePackageNameFromString.
mungeRelease :: String -> String
mungeRelease = intercalate "-" . prefixMaj . splitOn "."
  where
    prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs
    prefixFst _ _ [] = []
    prefixMaj = prefixFst "maj" prefixMin
    prefixMin = prefixFst "min" (map ('r':))

sysRelease :: HasLogFunc env => RIO env String
sysRelease =
  handleIO (\e -> do
               logWarn $ "Could not query OS version: " <> displayShow e
               pure "")
  (liftIO getRelease)

-- | Ensure Docker container-compatible 'stack' executable is downloaded
ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe containerPlatform = do
    config <- view configL
    containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
    let programsPath = configLocalProgramsBase config </> containerPlatformDir
        tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion)
    stackExeDir <- installDir programsPath tool
    let stackExePath = stackExeDir </> relFileStack
    stackExeExists <- doesFileExist stackExePath
    unless stackExeExists $ do
        logInfo $
          "Downloading Docker-compatible " <>
          fromString stackProgName <>
          " executable"
        sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion))
        platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)
        downloadStackExe platforms sri stackExeDir False (const $ pure ())
    pure stackExePath

-- | Get all executables on the path that might match the wanted compiler
sourceSystemCompilers
  :: (HasProcessContext env, HasLogFunc env)
  => WantedCompiler
  -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers wanted = do
  searchPath <- view exeSearchPathL
  names <-
    case wanted of
      WCGhc version -> pure
        [ "ghc-" ++ versionString version
        , "ghc"
        ]
      WCGhcjs{} -> throwIO GhcjsNotSupported
      WCGhcGit{} -> pure [] -- only use sandboxed versions
  for_ names $ \name -> for_ searchPath $ \dir -> do
    fp <- resolveFile' $ addExe $ dir FP.</> name
    exists <- doesFileExist fp
    when exists $ yield fp
  where
    addExe
      | osIsWindows = (++ ".exe")
      | otherwise = id

-- | Download the most recent SetupInfo
getSetupInfo :: HasConfig env => RIO env SetupInfo
getSetupInfo = do
    config <- view configL
    let inlineSetupInfo = configSetupInfoInline config
        locations' = configSetupInfoLocations config
        locations = if null locations' then [defaultSetupInfoYaml] else locations'

    resolvedSetupInfos <- mapM loadSetupInfo locations
    pure (inlineSetupInfo <> mconcat resolvedSetupInfos)
  where
    loadSetupInfo urlOrFile = do
      bs <-
          case parseUrlThrow urlOrFile of
              Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req
              Nothing -> liftIO $ S.readFile urlOrFile
      WithJSONWarnings si warnings <- either throwM pure (Yaml.decodeEither' bs)
      when (urlOrFile /= defaultSetupInfoYaml) $
          logJSONWarnings urlOrFile warnings
      pure si

getInstalledTool :: [Tool]            -- ^ already installed
                 -> PackageName       -- ^ package to find
                 -> (Version -> Bool) -- ^ which versions are acceptable
                 -> Maybe Tool
getInstalledTool installed name goodVersion = Tool <$>
  maximumByMaybe (comparing pkgVersion) (filterTools name goodVersion installed)

downloadAndInstallTool :: (HasTerm env, HasBuildConfig env)
                       => Path Abs Dir
                       -> DownloadInfo
                       -> Tool
                       -> (Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
                       -> RIO env Tool
downloadAndInstallTool programsDir downloadInfo tool installer = do
    ensureDir programsDir
    (file, at) <- downloadFromInfo programsDir downloadInfo tool
    dir <- installDir programsDir tool
    tempDir <- tempInstallDir programsDir tool
    liftIO $ ignoringAbsence (removeDirRecur tempDir)
    ensureDir tempDir
    unmarkInstalled programsDir tool
    installer file at tempDir dir
    markInstalled programsDir tool
    liftIO $ ignoringAbsence (removeDirRecur tempDir)
    pure tool

downloadAndInstallCompiler :: (HasBuildConfig env, HasGHCVariant env)
                           => CompilerBuild
                           -> SetupInfo
                           -> WantedCompiler
                           -> VersionCheck
                           -> Maybe String
                           -> RIO env Tool
downloadAndInstallCompiler ghcBuild si wanted@(WCGhc version) versionCheck mbindistURL = do
    ghcVariant <- view ghcVariantL
    (selectedVersion, downloadInfo) <- case mbindistURL of
        Just bindistURL -> do
            case ghcVariant of
                GHCCustom _ -> pure ()
                _ -> throwM RequireCustomGHCVariant
            pure (version, GHCDownloadInfo mempty mempty DownloadInfo
                     { downloadInfoUrl = T.pack bindistURL
                     , downloadInfoContentLength = Nothing
                     , downloadInfoSha1 = Nothing
                     , downloadInfoSha256 = Nothing
                     })
        _ -> do
            ghcKey <- getGhcKey ghcBuild
            case Map.lookup ghcKey $ siGHCs si of
                Nothing -> throwM $ UnknownOSKey ghcKey
                Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_
    config <- view configL
    let installer =
            case configPlatform config of
                Platform _ Cabal.Windows -> installGHCWindows
                _ -> installGHCPosix downloadInfo
    logInfo $
        "Preparing to install GHC" <>
        (case ghcVariant of
            GHCStandard -> ""
            v -> " (" <> fromString (ghcVariantName v) <> ")") <>
        (case ghcBuild of
            CompilerBuildStandard -> ""
            b -> " (" <> fromString (compilerBuildName b) <> ")") <>
        " to an isolated location."
    logInfo "This will not interfere with any system-level installation."
    ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
    let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
    downloadAndInstallTool (configLocalPrograms config) (gdiDownloadInfo downloadInfo) tool (installer si)

downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO GhcjsNotSupported

downloadAndInstallCompiler _ _ WCGhcGit{} _ _ =
    throwIO DownloadAndInstallCompilerError

getWantedCompilerInfo :: (Ord k, MonadThrow m)
                      => Text
                      -> VersionCheck
                      -> WantedCompiler
                      -> (k -> ActualCompiler)
                      -> Map k a
                      -> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs_ =
    case mpair of
        Just pair -> pure pair
        Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_))
  where
    mpair =
        listToMaybe $
        sortBy (flip (comparing fst)) $
        filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)

-- | Download and install the first available compiler build.
downloadAndInstallPossibleCompilers
    :: (HasGHCVariant env, HasBuildConfig env)
    => [CompilerBuild]
    -> SetupInfo
    -> WantedCompiler
    -> VersionCheck
    -> Maybe String
    -> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL =
    go possibleCompilers Nothing
  where
    -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or
    -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is nonexistent,
    -- not if the download or install fails for some other reason).
    -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception
    -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any
    -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions
    -- are unioned).
    go [] Nothing = throwM UnsupportedSetupConfiguration
    go [] (Just e) = throwM e
    go (b:bs) e = do
        logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b)
        er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL
        case er of
            Left e'@(UnknownCompilerVersion ks' w' vs') ->
                case e of
                    Nothing -> go bs (Just e')
                    Just (UnknownOSKey k) ->
                        go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs'
                    Just (UnknownCompilerVersion ks _ vs) ->
                        go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs)
                    Just x -> throwM x
            Left e'@(UnknownOSKey k') ->
                case e of
                    Nothing -> go bs (Just e')
                    Just (UnknownOSKey _) -> go bs e
                    Just (UnknownCompilerVersion ks w vs) ->
                        go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs
                    Just x -> throwM x
            Left e' -> throwM e'
            Right r -> pure (r, b)

getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
          => CompilerBuild -> m Text
getGhcKey ghcBuild = do
    ghcVariant <- view ghcVariantL
    platform <- view platformL
    osKey <- getOSKey platform
    pure $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)

getOSKey :: (MonadThrow m)
         => Platform -> m Text
getOSKey platform =
    case platform of
        Platform I386                  Cabal.Linux   -> pure "linux32"
        Platform X86_64                Cabal.Linux   -> pure "linux64"
        Platform I386                  Cabal.OSX     -> pure "macosx"
        Platform X86_64                Cabal.OSX     -> pure "macosx"
        Platform I386                  Cabal.FreeBSD -> pure "freebsd32"
        Platform X86_64                Cabal.FreeBSD -> pure "freebsd64"
        Platform I386                  Cabal.OpenBSD -> pure "openbsd32"
        Platform X86_64                Cabal.OpenBSD -> pure "openbsd64"
        Platform I386                  Cabal.Windows -> pure "windows32"
        Platform X86_64                Cabal.Windows -> pure "windows64"
        Platform Arm                   Cabal.Linux   -> pure "linux-armv7"
        Platform AArch64               Cabal.Linux   -> pure "linux-aarch64"
        Platform Sparc                 Cabal.Linux   -> pure "linux-sparc"
        Platform AArch64               Cabal.OSX     -> pure "macosx-aarch64"
        Platform AArch64               Cabal.FreeBSD -> pure "freebsd-aarch64"
        Platform arch os -> throwM $ UnsupportedSetupCombo os arch

downloadOrUseLocal
    :: (HasTerm env, HasBuildConfig env)
    => Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal downloadLabel downloadInfo destination =
  case url of
    (parseUrlThrow -> Just _) -> do
        ensureDir (parent destination)
        chattyDownload downloadLabel downloadInfo destination
        pure destination
    (parseAbsFile -> Just path) -> do
        warnOnIgnoredChecks
        pure path
    (parseRelFile -> Just path) -> do
        warnOnIgnoredChecks
        root <- view projectRootL
        pure (root </> path)
    _ -> throwIO $ URLInvalid url
  where
    url = T.unpack $ downloadInfoUrl downloadInfo
    warnOnIgnoredChecks = do
      let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1,
                       downloadInfoSha256=sha256} = downloadInfo
      when (isJust contentLength) $
        logWarn "`content-length` is not checked and should not be specified when `url` is a file path"
      when (isJust sha1) $
        logWarn "`sha1` is not checked and should not be specified when `url` is a file path"
      when (isJust sha256) $
        logWarn "`sha256` is not checked and should not be specified when `url` is a file path"

downloadFromInfo
    :: (HasTerm env, HasBuildConfig env)
    => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo programsDir downloadInfo tool = do
    archiveType <-
        case extension of
            ".tar.xz" -> pure TarXz
            ".tar.bz2" -> pure TarBz2
            ".tar.gz" -> pure TarGz
            ".7z.exe" -> pure SevenZ
            _ -> throwIO $ UnknownArchiveExtension url

    relativeFile <- parseRelFile $ toolString tool ++ extension
    let destinationPath = programsDir </> relativeFile
    localPath <- downloadOrUseLocal (T.pack (toolString tool)) downloadInfo destinationPath
    pure (localPath, archiveType)

  where
    url = T.unpack $ downloadInfoUrl downloadInfo
    extension = loop url
      where
        loop fp
            | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
            | otherwise = ""
          where
            (fp', ext) = FP.splitExtension fp


data ArchiveType
    = TarBz2
    | TarXz
    | TarGz
    | SevenZ

installGHCPosix :: HasConfig env
                => GHCDownloadInfo
                -> SetupInfo
                -> Path Abs File
                -> ArchiveType
                -> Path Abs Dir
                -> Path Abs Dir
                -> RIO env ()
installGHCPosix downloadInfo _ archiveFile archiveType tempDir destDir = do
    platform <- view platformL
    menv0 <- view processContextL
    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))
    logDebug $ "menv = " <> displayShow (view envVarsL menv)
    (zipTool', compOpt) <-
        case archiveType of
            TarXz -> pure ("xz", 'J')
            TarBz2 -> pure ("bzip2", 'j')
            TarGz -> pure ("gzip", 'z')
            SevenZ -> throwIO Unsupported7z
    -- Slight hack: OpenBSD's tar doesn't support xz.
    -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986
    let tarDep =
          case (platform, archiveType) of
            (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"
            _ -> checkDependency "tar"
    (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
        <$> checkDependency zipTool'
        <*> (checkDependency "gmake" <|> checkDependency "make")
        <*> tarDep

    logDebug $ "ziptool: " <> fromString zipTool
    logDebug $ "make: " <> fromString makeTool
    logDebug $ "tar: " <> fromString tarTool

    let runStep step wd env cmd args = do
          menv' <- modifyEnvVars menv (Map.union env)
          let logLines lvl = CB.lines .| CL.mapM_ (lvl . displayBytesUtf8)
              logStdout = logLines logDebug
              logStderr = logLines logError
          void $ withWorkingDir (toFilePath wd) $
                withProcessContext menv' $
                sinkProcessStderrStdout cmd args logStderr logStdout
                `catchAny` \ex ->
                    throwIO $ PrettyException
                      (GHCInstallFailed ex step cmd args wd tempDir destDir)

    logSticky $
      "Unpacking GHC into " <>
      fromString (toFilePath tempDir) <>
      " ..."
    logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)
    runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile]

    dir <- expectSingleUnpackedDir archiveFile tempDir

    mOverrideGccPath <- view $ configL.to configOverrideGccPath

    -- The make application uses the CC environment variable to configure the
    -- program for compiling C programs
    let mGccEnv = let gccEnvFromPath p =
                        Map.singleton "CC" $ T.pack (toFilePath p)
                  in  gccEnvFromPath <$> mOverrideGccPath

    -- Data.Map.union provides a left-biased union, so mGccEnv will prevail
    let ghcConfigureEnv =
          fromMaybe Map.empty mGccEnv `Map.union` gdiConfigureEnv downloadInfo

    logSticky "Configuring GHC ..."
    runStep "configuring" dir
        ghcConfigureEnv
        (toFilePath $ dir </> relFileConfigure)
        (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo))

    logSticky "Installing GHC ..."
    runStep "installing" dir mempty makeTool ["install"]

    logStickyDone $ "Installed GHC."
    logDebug $ "GHC installed to " <> fromString (toFilePath destDir)

-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: CheckDependency env a -> RIO env a
checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) pure

checkDependency :: HasProcessContext env => String -> CheckDependency env String
checkDependency tool = CheckDependency $ do
    exists <- doesExecutableExist tool
    pure $ if exists then Right tool else Left [tool]

newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))
    deriving Functor
instance Applicative (CheckDependency env) where
    pure x = CheckDependency $ pure (Right x)
    CheckDependency f <*> CheckDependency x = CheckDependency $ do
        f' <- f
        x' <- x
        pure $
            case (f', x') of
                (Left e1, Left e2) -> Left $ e1 ++ e2
                (Left e, Right _) -> Left e
                (Right _, Left e) -> Left e
                (Right f'', Right x'') -> Right $ f'' x''
instance Alternative (CheckDependency env) where
    empty = CheckDependency $ pure $ Left []
    CheckDependency x <|> CheckDependency y = CheckDependency $ do
        res1 <- x
        case res1 of
            Left _ -> y
            Right x' -> pure $ Right x'

installGHCWindows :: HasBuildConfig env
                  => SetupInfo
                  -> Path Abs File
                  -> ArchiveType
                  -> Path Abs Dir
                  -> Path Abs Dir
                  -> RIO env ()
installGHCWindows si archiveFile archiveType _tempDir destDir = do
    withUnpackedTarball7z "GHC" si archiveFile archiveType destDir
    logInfo $ "GHC installed to " <> fromString (toFilePath destDir)

installMsys2Windows :: HasBuildConfig env
                  => SetupInfo
                  -> Path Abs File
                  -> ArchiveType
                  -> Path Abs Dir
                  -> Path Abs Dir
                  -> RIO env ()
installMsys2Windows si archiveFile archiveType _tempDir destDir = do
    exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
    when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do
        throwM $ ExistingMSYS2NotDeleted destDir e

    withUnpackedTarball7z "MSYS2" si archiveFile archiveType destDir


    -- I couldn't find this officially documented anywhere, but you need to run
    -- the MSYS shell once in order to initialize some pacman stuff. Once that
    -- run happens, you can just run commands as usual.
    menv0 <- view processContextL
    newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"
    newEnv <- either throwM pure $ augmentPathMap
                  [toFilePath $ destDir </> relDirUsr </> relDirBin]
                  (view envVarsL newEnv0)
    menv <- mkProcessContext newEnv
    withWorkingDir (toFilePath destDir) $ withProcessContext menv
      $ proc "sh" ["--login", "-c", "true"] runProcess_

    -- No longer installing git, it's unreliable
    -- (https://github.com/commercialhaskell/stack/issues/1046) and the
    -- MSYS2-installed version has bad CRLF defaults.
    --
    -- Install git. We could install other useful things in the future too.
    -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing

-- | Unpack a compressed tarball using 7zip.  Expects a single directory in
-- the unpacked results, which is renamed to the destination directory.
withUnpackedTarball7z :: HasBuildConfig env
                      => String -- ^ Name of tool, used in error messages
                      -> SetupInfo
                      -> Path Abs File -- ^ Path to archive file
                      -> ArchiveType
                      -> Path Abs Dir -- ^ Destination directory.
                      -> RIO env ()
withUnpackedTarball7z name si archiveFile archiveType destDir = do
    suffix <-
        case archiveType of
            TarXz -> pure ".xz"
            TarBz2 -> pure ".bz2"
            TarGz -> pure ".gz"
            _ -> throwIO $ TarballInvalid name
    tarFile <-
        case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of
            Nothing -> throwIO $ TarballFileInvalid name archiveFile
            Just x -> parseRelFile $ T.unpack x
    run7z <- setup7z si
    let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"
    ensureDir (parent destDir)
    withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do
        liftIO $ ignoringAbsence (removeDirRecur destDir)
        run7z tmpDir archiveFile
        run7z tmpDir (tmpDir </> tarFile)
        absSrcDir <- expectSingleUnpackedDir archiveFile tmpDir
        renameDir absSrcDir destDir

expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir archiveFile destDir = do
    contents <- listDir destDir
    case contents of
        ([dir], _ ) -> pure dir
        _ -> throwIO $ UnknownArchiveStructure archiveFile

-- | Download 7z as necessary, and get a function for unpacking things.
--
-- Returned function takes an unpack directory and archive.
setup7z :: (HasBuildConfig env, MonadIO m)
        => SetupInfo
        -> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z si = do
    dir <- view $ configL.to configLocalPrograms
    ensureDir dir
    let exeDestination = dir </> relFile7zexe
        dllDestination = dir </> relFile7zdll
    case (siSevenzDll si, siSevenzExe si) of
        (Just sevenzDll, Just sevenzExe) -> do
            _ <- downloadOrUseLocal "7z.dll" sevenzDll dllDestination
            exePath <- downloadOrUseLocal "7z.exe" sevenzExe exeDestination
            withRunInIO $ \run -> pure $ \outdir archive -> liftIO $ run $ do
                let cmd = toFilePath exePath
                    args =
                        [ "x"
                        , "-o" ++ toFilePath outdir
                        , "-y"
                        , toFilePath archive
                        ]
                let archiveDisplay = fromString $ FP.takeFileName $ toFilePath archive
                    isExtract = FP.takeExtension (toFilePath archive) == ".tar"
                logInfo $
                  (if isExtract then "Extracting " else "Decompressing ") <>
                  archiveDisplay <> "..."
                ec <-
                  proc cmd args $ \pc ->
                  if isExtract
                    then withProcessWait (setStdout createSource pc) $ \p -> do
                        total <- runConduit
                            $ getStdout p
                           .| filterCE (== 10) -- newline characters
                           .| foldMC
                                (\count bs -> do
                                    let count' = count + S.length bs
                                    logSticky $ "Extracted " <> display count' <> " files"
                                    pure count'
                                )
                                0
                        logStickyDone $
                          "Extracted total of " <>
                          display total <>
                          " files from " <>
                          archiveDisplay
                        waitExitCode p
                    else runProcess pc
                when (ec /= ExitSuccess)
                    $ liftIO $ throwM (ProblemWhileDecompressing archive)
        _ -> throwM SetupInfoMissingSevenz

chattyDownload :: HasTerm env
               => Text          -- ^ label
               -> DownloadInfo  -- ^ URL, content-length, sha1, and sha256
               -> Path Abs File -- ^ destination
               -> RIO env ()
chattyDownload label downloadInfo path = do
    let url = downloadInfoUrl downloadInfo
    req <- parseUrlThrow $ T.unpack url
    logSticky $
      "Preparing to download " <>
      display label <>
      " ..."
    logDebug $
      "Downloading from " <>
      display url <>
      " to " <>
      fromString (toFilePath path) <>
      " ..."
    hashChecks <- fmap catMaybes $ forM
      [ ("sha1",   HashCheck SHA1,   downloadInfoSha1)
      , ("sha256", HashCheck SHA256, downloadInfoSha256)
      ]
      $ \(name, constr, getter) ->
        case getter downloadInfo of
          Just bs -> do
            logDebug $
                "Will check against " <>
                name <>
                " hash: " <>
                displayBytesUtf8 bs
            pure $ Just $ constr $ CheckHexDigestByteString bs
          Nothing -> pure Nothing
    when (null hashChecks) $ logWarn $
        "No sha1 or sha256 found in metadata," <>
        " download hash won't be checked."
    let dReq = setHashChecks hashChecks $
               setLengthCheck mtotalSize $
               mkDownloadRequest req
    x <- verifiedDownloadWithProgress dReq path label mtotalSize
    if x
        then logStickyDone ("Downloaded " <> display label <> ".")
        else logStickyDone "Already downloaded."
  where
    mtotalSize = downloadInfoContentLength downloadInfo

-- | Perform a basic sanity check of GHC
sanityCheck :: (HasProcessContext env, HasLogFunc env)
            => Path Abs File -> RIO env ()
sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do
    let fp = toFilePath $ dir </> relFileMainHs
    liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines
        [ "import Distribution.Simple" -- ensure Cabal library is present
        , "main = putStrLn \"Hello World\""
        ]
    logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc)
    eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc)
        [ fp
        , "-no-user-package-db"
        ] $ try . readProcess_
    case eres of
        Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc
        Right _ -> pure () -- TODO check that the output of running the command is correct

-- Remove potentially confusing environment variables
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
    Map.delete "GHC_PACKAGE_PATH" .
    Map.delete "GHC_ENVIRONMENT" .
    Map.delete "HASKELL_PACKAGE_SANDBOX" .
    Map.delete "HASKELL_PACKAGE_SANDBOXES" .
    Map.delete "HASKELL_DIST_DIR" .
    -- https://github.com/commercialhaskell/stack/issues/1460
    Map.delete "DESTDIR" .
    -- https://github.com/commercialhaskell/stack/issues/3444
    Map.delete "GHCRTS"

-- | Get map of environment variables to set to change the GHC's encoding to UTF-8
getUtf8EnvVars
    :: (HasProcessContext env, HasPlatform env, HasLogFunc env)
    => ActualCompiler
    -> RIO env (Map Text Text)
getUtf8EnvVars compilerVer =
    if getGhcVersion compilerVer >= mkVersion [7, 10, 3]
        -- GHC_CHARENC supported by GHC >=7.10.3
        then pure $ Map.singleton "GHC_CHARENC" "UTF-8"
        else legacyLocale
  where
    legacyLocale = do
        menv <- view processContextL
        Platform _ os <- view platformL
        if os == Cabal.Windows
            then
                 -- On Windows, locale is controlled by the code page, so we don't set any environment
                 -- variables.
                 pure
                     Map.empty
            else do
                let checkedVars = map checkVar (Map.toList $ view envVarsL menv)
                    -- List of environment variables that will need to be updated to set UTF-8 (because
                    -- they currently do not specify UTF-8).
                    needChangeVars = concatMap fst checkedVars
                    -- Set of locale-related environment variables that have already have a value.
                    existingVarNames = Set.unions (map snd checkedVars)
                    -- True if a locale is already specified by one of the "global" locale variables.
                    hasAnyExisting =
                        any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]
                if null needChangeVars && hasAnyExisting
                    then
                         -- If no variables need changes and at least one "global" variable is set, no
                         -- changes to environment need to be made.
                         pure
                             Map.empty
                    else do
                        -- Get a list of known locales by running @locale -a@.
                        elocales <- tryAny $ fmap fst $ proc "locale" ["-a"] readProcess_
                        let
                            -- Filter the list to only include locales with UTF-8 encoding.
                            utf8Locales =
                                case elocales of
                                    Left _ -> []
                                    Right locales ->
                                        filter
                                            isUtf8Locale
                                            (T.lines $
                                             T.decodeUtf8With
                                                 T.lenientDecode $
                                                 LBS.toStrict locales)
                            mfallback = getFallbackLocale utf8Locales
                        when
                            (isNothing mfallback)
                            (logWarn
                                 "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")
                        let
                            -- Get the new values of variables to adjust.
                            changes =
                                Map.unions $
                                map
                                    (adjustedVarValue menv utf8Locales mfallback)
                                    needChangeVars
                            -- Get the values of variables to add.
                            adds
                              | hasAnyExisting =
                                  -- If we already have a "global" variable, then nothing needs
                                  -- to be added.
                                  Map.empty
                              | otherwise =
                                  -- If we don't already have a "global" variable, then set LANG to the
                                  -- fallback.
                                  case mfallback of
                                      Nothing -> Map.empty
                                      Just fallback ->
                                          Map.singleton "LANG" fallback
                        pure (Map.union changes adds)
    -- Determines whether an environment variable is locale-related and, if so, whether it needs to
    -- be adjusted.
    checkVar
        :: (Text, Text) -> ([Text], Set Text)
    checkVar (k,v) =
        if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k
            then if isUtf8Locale v
                     then ([], Set.singleton k)
                     else ([k], Set.singleton k)
            else ([], Set.empty)
    -- Adjusted value of an existing locale variable.  Looks for valid UTF-8 encodings with
    -- same language /and/ territory, then with same language, and finally the first UTF-8 locale
    -- returned by @locale -a@.
    adjustedVarValue
        :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text
    adjustedVarValue menv utf8Locales mfallback k =
        case Map.lookup k (view envVarsL menv) of
            Nothing -> Map.empty
            Just v ->
                case concatMap
                         (matchingLocales utf8Locales)
                         [ T.takeWhile (/= '.') v <> "."
                         , T.takeWhile (/= '_') v <> "_"] of
                    (v':_) -> Map.singleton k v'
                    [] ->
                        case mfallback of
                            Just fallback -> Map.singleton k fallback
                            Nothing -> Map.empty
    -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in
    -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale
    -- -a@.
    getFallbackLocale
        :: [Text] -> Maybe Text
    getFallbackLocale utf8Locales =
        case concatMap (matchingLocales utf8Locales) fallbackPrefixes of
            (v:_) -> Just v
            [] ->
                case utf8Locales of
                    [] -> Nothing
                    (v:_) -> Just v
    -- Filter the list of locales for any with the given prefixes (case-insensitive).
    matchingLocales
        :: [Text] -> Text -> [Text]
    matchingLocales utf8Locales prefix =
        filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales
    -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?
    isUtf8Locale locale =
      any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes
    -- Prefixes of fallback locales (case-insensitive)
    fallbackPrefixes = ["C.", "en_US.", "en_"]
    -- Suffixes of UTF-8 locales (case-insensitive)
    utf8Suffixes = [".UTF-8", ".utf8"]

-- Binary Stack upgrades

-- | Information on a binary release of Stack
data StackReleaseInfo
  = SRIGitHub !Value
  -- ^ Metadata downloaded from GitHub releases about available binaries.
  | SRIHaskellStackOrg !HaskellStackOrg
  -- ^ Information on the latest available binary for the current platforms.

data HaskellStackOrg = HaskellStackOrg
  { hsoUrl :: !Text
  , hsoVersion :: !Version
  }
  deriving Show

downloadStackReleaseInfo
  :: (HasPlatform env, HasLogFunc env)
  => Maybe String -- GitHub org
  -> Maybe String -- GitHub repo
  -> Maybe String -- ^ optional version
  -> RIO env StackReleaseInfo
downloadStackReleaseInfo Nothing Nothing Nothing = do
    platform <- view platformL
    -- Fallback list of URLs to try for upgrading.
    let urls0 =
          case platform of
            Platform X86_64 Cabal.Linux ->
              [ "https://get.haskellstack.org/upgrade/linux-x86_64-static.tar.gz"
              , "https://get.haskellstack.org/upgrade/linux-x86_64.tar.gz"
              ]
            Platform X86_64 Cabal.OSX ->
              [ "https://get.haskellstack.org/upgrade/osx-x86_64.tar.gz"
              ]
            Platform X86_64 Cabal.Windows ->
              [ "https://get.haskellstack.org/upgrade/windows-x86_64.tar.gz"
              ]
            _ -> []
        -- Helper function: extract the version from a GitHub releases URL.
    let extractVersion loc = do
          version0 <-
            case reverse $ splitOn "/" $ T.unpack loc of
              _final:version0:_ -> Right version0
              _ -> Left $ "Insufficient pieces in location: " ++ show loc
          version1 <- maybe (Left "no leading v on version") Right $ stripPrefix "v" version0
          maybe (Left $ "Invalid version: " ++ show version1) Right $ parseVersion version1

        -- Try out different URLs. If we've exhausted all of them, fall back to GitHub.
        loop [] = do
          logDebug "Could not get binary from haskellstack.org, trying GitHub"
          downloadStackReleaseInfoGitHub Nothing Nothing Nothing

        -- Try the next URL
        loop (url:urls) = do
          -- Make a HEAD request without any redirects
          req <- setRequestMethod "HEAD" <$> parseRequest (T.unpack url)
          res <- httpLbs req { redirectCount = 0 }

          -- Look for a redirect. We're looking for a standard GitHub releases
          -- URL where we can extract version information from.
          case getResponseHeader "location" res of
            [] -> logDebug "No location header found, continuing" *> loop urls
            -- Exactly one location header.
            [locBS] ->
              case decodeUtf8' locBS of
                Left e -> logDebug ("Invalid UTF8: " <> displayShow (locBS, e)) *> loop urls
                Right loc ->
                  case extractVersion loc of
                    Left s -> logDebug ("No version found: " <> displayShow (url, loc, s)) *> loop (loc:urls)
                    -- We found a valid URL, let's use it!
                    Right version -> do
                      let hso = HaskellStackOrg
                                  { hsoUrl = loc
                                  , hsoVersion = version
                                  }
                      logDebug $ "Downloading from haskellstack.org: " <> displayShow hso
                      pure $ SRIHaskellStackOrg hso
            locs -> logDebug ("Multiple location headers found: " <> displayShow locs) *> loop urls
    loop urls0
downloadStackReleaseInfo morg mrepo mver = downloadStackReleaseInfoGitHub morg mrepo mver

-- | Same as above, but always uses GitHub
downloadStackReleaseInfoGitHub
  :: (MonadIO m, MonadThrow m)
  => Maybe String -- GitHub org
  -> Maybe String -- GitHub repo
  -> Maybe String -- ^ optional version
  -> m StackReleaseInfo
downloadStackReleaseInfoGitHub morg mrepo mver = liftIO $ do
    let org = fromMaybe "commercialhaskell" morg
        repo = fromMaybe "stack" mrepo
    let url = concat
            [ "https://api.github.com/repos/"
            , org
            , "/"
            , repo
            , "/releases/"
            , case mver of
                Nothing -> "latest"
                Just ver -> "tags/v" ++ ver
            ]
    req <- parseRequest url
    res <- httpJSON $ setGitHubHeaders req
    let code = getResponseStatusCode res
    if code >= 200 && code < 300
        then pure $ SRIGitHub $ getResponseBody res
        else throwIO $ StackReleaseInfoNotFound url

preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)
                   => m [(Bool, String)]
preferredPlatforms = do
    Platform arch' os' <- view platformL
    (isWindows, os) <-
      case os' of
        Cabal.Linux -> pure (False, "linux")
        Cabal.Windows -> pure (True, "windows")
        Cabal.OSX -> pure (False, "osx")
        Cabal.FreeBSD -> pure (False, "freebsd")
        _ -> throwM $ BinaryUpgradeOnOSUnsupported os'
    arch <-
      case arch' of
        I386 -> pure "i386"
        X86_64 -> pure "x86_64"
        Arm -> pure "arm"
        _ -> throwM $ BinaryUpgradeOnArchUnsupported arch'
    hasgmp4 <- pure False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
    let suffixes
          | hasgmp4 = ["-static", "-gmp4", ""]
          | otherwise = ["-static", ""]
    pure $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes

downloadStackExe
    :: HasConfig env
    => [(Bool, String)] -- ^ acceptable platforms
    -> StackReleaseInfo
    -> Path Abs Dir -- ^ destination directory
    -> Bool -- ^ perform PATH-aware checking, see #3232
    -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming
    -> RIO env ()
downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do
    (isWindows, archiveURL) <-
      let loop [] = throwIO $ StackBinaryArchiveNotFound (map snd platforms0)
          loop ((isWindows, p'):ps) = do
            let p = T.pack p'
            logInfo $ "Querying for archive location for platform: " <> fromString p'
            case findArchive archiveInfo p of
              Just x -> pure (isWindows, x)
              Nothing -> loop ps
       in loop platforms0

    let (destFile, tmpFile)
            | isWindows =
                ( destDir </> relFileStackDotExe
                , destDir </> relFileStackDotTmpDotExe
                )
            | otherwise =
                ( destDir </> relFileStack
                , destDir </> relFileStackDotTmp
                )

    logInfo $ "Downloading from: " <> display archiveURL

    liftIO $ do
      case () of
        ()
          | ".tar.gz" `T.isSuffixOf` archiveURL ->
              handleTarball tmpFile isWindows archiveURL
          | ".zip" `T.isSuffixOf` archiveURL ->
              throwIO StackBinaryArchiveZipUnsupportedBug
          | otherwise -> throwIO $ StackBinaryArchiveUnsupported archiveURL

    logInfo "Download complete, testing executable"

    platform <- view platformL

    -- We need to call getExecutablePath before we overwrite the
    -- currently running binary: after that, Linux will append
    -- (deleted) to the filename.
    currExe <- liftIO getExecutablePath

    liftIO $ do
      setFileExecutable (toFilePath tmpFile)

      testExe tmpFile

      case platform of
          Platform _ Cabal.Windows | FP.equalFilePath (toFilePath destFile) currExe -> do
              old <- parseAbsFile (toFilePath destFile ++ ".old")
              renameFile destFile old
              renameFile tmpFile destFile
          _ -> renameFile tmpFile destFile

    destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
    warnInstallSearchPathIssues destDir' ["stack"]

    logInfo $ "New Stack executable available at " <> fromString (toFilePath destFile)

    when checkPath $ performPathChecking destFile currExe
      `catchAny` (logError . displayShow)
  where

    findArchive (SRIGitHub val) pattern = do
        Object top <- pure val
        Array assets <- KeyMap.lookup "assets" top
        getFirst $ fold $ fmap (First . findMatch pattern') assets
      where
        pattern' = mconcat ["-", pattern, "."]

        findMatch pattern'' (Object o) = do
            String name <- KeyMap.lookup "name" o
            guard $ not $ ".asc" `T.isSuffixOf` name
            guard $ pattern'' `T.isInfixOf` name
            String url <- KeyMap.lookup "browser_download_url" o
            Just url
        findMatch _ _ = Nothing
    findArchive (SRIHaskellStackOrg hso) _ = pure $ hsoUrl hso

    handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()
    handleTarball tmpFile isWindows url = do
        req <- fmap setGitHubHeaders $ parseUrlThrow $ T.unpack url
        withResponse req $ \res -> do
            entries <- fmap (Tar.read . LBS.fromChunks)
                     $ lazyConsume
                     $ getResponseBody res .| ungzip
            let loop Tar.Done = throwIO $ StackBinaryNotInArchive exeName url
                loop (Tar.Fail e) = throwM e
                loop (Tar.Next e es) =
                    case FP.splitPath (Tar.entryPath e) of
                        -- Ignore the first component, see: https://github.com/commercialhaskell/stack/issues/5288
                        [_ignored, name] | name == exeName -> do
                            case Tar.entryContent e of
                                Tar.NormalFile lbs _ -> do
                                  ensureDir destDir
                                  LBS.writeFile (toFilePath tmpFile) lbs
                                _ -> throwIO $ FileTypeInArchiveInvalid e url
                        _ -> loop es
            loop entries
      where
        exeName
          | isWindows = "stack.exe"
          | otherwise = "stack"

-- | Ensure that the Stack executable download is in the same location
-- as the currently running executable. See:
-- https://github.com/commercialhaskell/stack/issues/3232
performPathChecking
    :: HasConfig env
    => Path Abs File -- ^ location of the newly downloaded file
    -> String -- ^ currently running executable
    -> RIO env ()
performPathChecking newFile executablePath = do
  executablePath' <- parseAbsFile executablePath
  unless (toFilePath newFile == executablePath) $ do
    logInfo $ "Also copying Stack executable to " <> fromString executablePath
    tmpFile <- parseAbsFile $ executablePath ++ ".tmp"
    eres <- tryIO $ do
      liftIO $ copyFile newFile tmpFile
      setFileExecutable (toFilePath tmpFile)
      liftIO $ renameFile tmpFile executablePath'
      logInfo "Stack executable copied successfully!"
    case eres of
      Right () -> pure ()
      Left e
        | isPermissionError e -> do
            logWarn $ "Permission error when trying to copy: " <> displayShow e
            logWarn "Should I try to perform the file copy using sudo? This may fail"
            toSudo <- promptBool "Try using sudo? (y/n) "
            when toSudo $ do
              let run cmd args = do
                    ec <- proc cmd args runProcess
                    when (ec /= ExitSuccess) $
                        throwIO $ ProcessExited ec cmd args
                  commands =
                    [ ("sudo",
                        [ "cp"
                        , toFilePath newFile
                        , toFilePath tmpFile
                        ])
                    , ("sudo",
                        [ "mv"
                        , toFilePath tmpFile
                        , executablePath
                        ])
                    ]
              logInfo "Going to run the following commands:"
              logInfo ""
              forM_ commands $ \(cmd, args) ->
                logInfo $ "-  " <> mconcat (intersperse " " (fromString <$> (cmd:args)))
              mapM_ (uncurry run) commands
              logInfo ""
              logInfo "sudo file copy worked!"
        | otherwise -> throwM e

getDownloadVersion :: StackReleaseInfo -> Maybe Version
getDownloadVersion (SRIGitHub val) = do
    Object o <- Just val
    String rawName <- KeyMap.lookup "name" o
    -- drop the "v" at the beginning of the name
    parseVersion $ T.unpack (T.drop 1 rawName)
getDownloadVersion (SRIHaskellStackOrg hso) = Just $ hsoVersion hso
