content: {-# LANGUAGE NoImplicitPrelude     #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE OverloadedRecordDot   #-}
  {-# LANGUAGE OverloadedStrings     #-}
  
  {-|
  Module      : Stack.Upgrade
  Description : Function related to Stack's @upgrade@ command.
  License     : BSD-3-Clause
  
  Function related to Stack's @upgrade@ command.
  -}
  
  module Stack.Upgrade
    ( upgradeCmd
    ) where
  
  import qualified Data.Text as T
  import           Path ( (</>), parseRelDir )
  import           RIO.Process ( proc, runProcess_, withWorkingDir )
  import           Stack.Build ( build )
  import           Stack.Build.Target ( NeedTargets (..) )
  import           Stack.BuildInfo ( maybeGitHash )
  import           Stack.Constants ( relDirStackProgName, stackDotYaml )
  import           Stack.Prelude hiding ( force, Display (..) )
  import           Stack.Runners
                     ( ShouldReexec (..), withConfig, withEnvConfig
                     , withGlobalProject )
  import           Stack.Setup
                     ( downloadStackExe, downloadStackReleaseInfo
                     , getDownloadVersion, preferredPlatforms, stackVersion
                     )
  import           Stack.Types.BuildOpts ( buildOptsInstallExesL )
  import           Stack.Types.BuildOptsCLI
                     ( BuildOptsCLI (..), defaultBuildOptsCLI )
  import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
  import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
  import           Stack.Types.Runner ( Runner, globalOptsL )
  import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
  import           Stack.Types.UpgradeOpts
                     ( BinaryOpts (..), SourceOpts (..), UpgradeOpts (..) )
  import           System.Process ( rawSystem, readProcess )
  
  -- | Type representing \'pretty\' exceptions thrown by functions in the
  -- "Stack.Upgrade" module.
  data UpgradePrettyException
    = SnapshotOptionInvalid
    | NeitherBinaryOrSourceSpecified
    | ExecutableFailure
    | CommitsNotFound String String
    | StackInPackageIndexNotFound
    | VersionWithNoRevision
    deriving Show
  
  instance Pretty UpgradePrettyException where
    pretty SnapshotOptionInvalid =
      "[S-8761]"
      <> line
      <> fillSep
           [ "The"
           , style Shell "--snapshot"
           , flow "option cannot be used with Stack's"
           , style Shell "upgrade"
           , "command."
           ]
    pretty NeitherBinaryOrSourceSpecified =
      "[S-3642]"
      <> line
      <> flow "You must allow either binary or source upgrade paths."
    pretty ExecutableFailure =
      "[S-8716]"
      <> line
      <> flow "Non-success exit code from running newly downloaded executable."
    pretty (CommitsNotFound branch repo) =
      "[S-7114]"
      <> line
      <> fillSep
           [ flow "No commits found for branch"
           , style Current (fromString branch)
           , flow "on repo"
           , style Url (fromString repo) <> "."
           ]
    pretty StackInPackageIndexNotFound =
      "[S-9668]"
      <> line
      <> flow "No Stack version found in package indices."
    pretty VersionWithNoRevision =
      "[S-6648]"
      <> line
      <> flow "Latest version with no revision."
  
  instance Exception UpgradePrettyException
  
  -- | Function underlying the @stack upgrade@ command.
  upgradeCmd :: UpgradeOpts -> RIO Runner ()
  upgradeCmd upgradeOpts = do
    go <- view globalOptsL
    case go.snapshot of
      Just _ -> prettyThrowIO SnapshotOptionInvalid
      Nothing -> withGlobalProject $ upgrade maybeGitHash upgradeOpts
  
  upgrade ::
       Maybe String -- ^ git hash at time of building, if known
    -> UpgradeOpts
    -> RIO Runner ()
  upgrade builtHash (UpgradeOpts mbo mso) = case (mbo, mso) of
    -- FIXME It would be far nicer to capture this case in the options parser
    -- itself so we get better error messages, but I can't think of a way to
    -- make it happen.
    (Nothing, Nothing) -> prettyThrowIO NeitherBinaryOrSourceSpecified
    (Just bo, Nothing) -> binary bo
    (Nothing, Just so) -> source so
    -- See #2977 - if --git or --git-repo is specified, do source upgrade.
    (_, Just so@(SourceOpts (Just _))) -> source so
    (Just bo, Just so) -> binary bo `catchAny` \e -> do
      prettyWarn $
           flow "When trying to perform binary upgrade, Stack encountered the \
                \following error:"
        <> blankLine
        <> ppException e
        <> blankLine
        <> flow "Falling back to source upgrade."
      source so
   where
    binary = binaryUpgrade
    source = sourceUpgrade builtHash
  
  binaryUpgrade :: BinaryOpts -> RIO Runner ()
  binaryUpgrade (BinaryOpts mplatform force' onlyLocalBin mver morg mrepo) =
    withConfig NoReexec $ do
      platforms0 <-
        case mplatform of
          Nothing -> preferredPlatforms
          Just p -> pure [("windows" `T.isInfixOf` T.pack p, p)]
      archiveInfo <- downloadStackReleaseInfo morg mrepo mver
      let mdownloadVersion = getDownloadVersion archiveInfo
          force =
            case mver of
              Nothing -> force'
              Just _ -> True -- specifying a version implies we're forcing things
      isNewer <-
        case mdownloadVersion of
          Nothing -> do
            prettyError $
                 flow "Unable to determine upstream version from GitHub metadata."
              <> if force
                   then mempty
                   else
                        line
                     <> fillSep
                          [ flow "Rerun with"
                          , style Shell "--force-download"
                          , flow "to force an upgrade."
                          ]
            pure False
          Just downloadVersion -> do
            prettyInfoL
              [ flow "Current Stack version:"
              , fromString (versionString stackVersion) <> ";"
              , flow "available download version:"
              , fromString (versionString downloadVersion) <> "."
              ]
            pure $ downloadVersion > stackVersion
      toUpgrade <- case (force, isNewer) of
        (False, False) -> do
          prettyInfoS "Skipping binary upgrade, you are already running the most \
                      \recent version."
          pure False
        (True, False) -> do
          prettyInfoS "Forcing binary upgrade."
          pure True
        (_, True) -> do
          prettyInfoS "Newer version detected, downloading."
          pure True
      when toUpgrade $ do
        config <- view configL
        downloadStackExe
          platforms0 archiveInfo config.localBin (not onlyLocalBin) $
            \tmpFile -> do
              -- Sanity check!
              ec <- rawSystem (toFilePath tmpFile) ["--version"]
              unless (ec == ExitSuccess) (prettyThrowIO ExecutableFailure)
  
  sourceUpgrade ::
       Maybe String
    -> SourceOpts
    -> RIO Runner ()
  sourceUpgrade builtHash (SourceOpts gitRepo) =
    withSystemTempDir "stack-upgrade" $ \tmp -> do
      mdir <- case gitRepo of
        Just (repo, branch) -> do
          remote <- liftIO $ System.Process.readProcess
            "git"
            ["ls-remote", repo, branch]
            []
          latestCommit <-
            case words remote of
              [] -> prettyThrowIO $ CommitsNotFound branch repo
              x:_ -> pure x
          when (isNothing builtHash) $
            prettyWarnS
              "Information about the commit this version of Stack was built from \
              \is not available due to how it was built. Will continue by \
              \assuming an upgrade is needed because we have no information to \
              \the contrary."
          if builtHash == Just latestCommit
              then do
                prettyInfoS "Already up-to-date, no upgrade required."
                pure Nothing
              else do
                prettyInfoS "Cloning stack."
                -- NOTE: "--recursive" was added after v1.0.0 (and before the next
                -- release).  This means that we can't use submodules in the Stack
                -- repo until we're comfortable with "stack upgrade --git" not
                -- working for earlier versions.
                let args =
                      [ "clone"
                      , repo
                      , "stack"
                      , "--depth"
                      , "1"
                      , "--recursive"
                      , "--branch"
                      , branch
                      ]
                withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_
                pure $ Just $ tmp </> relDirStackProgName
        -- We need to access the Pantry database to find out about the latest
        -- Stack available on Hackage. We first use a standard Config to do this,
        -- and once we have the source load up the stack.yaml from inside that
        -- source.
        Nothing -> withConfig NoReexec $ do
          void
            $ updateHackageIndex
            $ Just "Updating index to make sure we find the latest Stack version."
          mversion <- getLatestHackageVersion
            YesRequireHackageIndex
            "stack"
            UsePreferredVersions
          (PackageIdentifierRevision _ version _) <-
            case mversion of
              Nothing -> prettyThrowIO StackInPackageIndexNotFound
              Just version -> pure version
          if version <= stackVersion
            then do
              prettyInfoS "Already at latest version, no upgrade required."
              pure Nothing
            else do
              suffix <- parseRelDir $ "stack-" ++ versionString version
              let dir = tmp </> suffix
              mrev <- getLatestHackageRevision
                YesRequireHackageIndex
                "stack"
                version
              case mrev of
                Nothing -> prettyThrowIO VersionWithNoRevision
                Just (_rev, cfKey, treeKey) -> do
                  let ident = PackageIdentifier "stack" version
                  unpackPackageLocation dir $ PLIHackage ident cfKey treeKey
                  pure $ Just dir
  
      let modifyGO dir go = go
            { snapshot = Nothing -- always use the snapshot settings in the
                                 -- stack.yaml file
            , stackYaml = SYLOverride $ dir </> stackDotYaml
            }
          boptsCLI = defaultBuildOptsCLI { targetsCLI = ["stack"] }
      forM_ mdir $ \dir ->
        local (over globalOptsL (modifyGO dir))
          $ withConfig NoReexec
          $ withEnvConfig AllowNoTargets boptsCLI
          $ local (set (buildOptsL . buildOptsInstallExesL) True)
          $ build Nothing
  