Publish.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.CLI.Command.Release.Publish
  ( PublishOptions (..),
    runPublish,
  )
where

import Control.Monad.Error.Class (MonadError (..))
import qualified Data.Map as Map
import HWM.Core.Common (Name)
import HWM.Core.Formatting
  ( Color (..),
    Format (..),
    Status (Checked, Invalid),
    chalk,
    genMaxLen,
    statusIcon,
  )
import HWM.Core.Parsing (ParseCLI (..))
import HWM.Core.Pkg (Pkg (..))
import HWM.Core.Result (Issue (..), MonadIssue (..), Severity (..), maxSeverity)
import HWM.Domain.Config (Config (cfgRelease))
import HWM.Domain.ConfigT (ConfigT, Env (..), askVersion)
import HWM.Domain.Dependencies (sortByDependencyHierarchy)
import HWM.Domain.Release (Release (..))
import HWM.Domain.Workspace (WsPkgs, printPkgWSRef, resolveWsPkgs)
import HWM.Integrations.Toolchain.Cabal (nativeSdist)
import HWM.Integrations.Toolchain.Package (deriveDependencyGraph)
import HWM.Runtime.Network (getHackageToken, uploadToHackage)
import HWM.Runtime.UI (printSummary, sectionTableM, section_, uiSubPathRow)
import Options.Applicative (argument, help, long, metavar, str)
import Options.Applicative.Builder (switch)
import Relude hiding (intercalate)
import System.Directory (getCurrentDirectory)
import System.FilePath (makeRelative)

failIssues :: [Issue] -> ConfigT ()
failIssues [] = pure ()
failIssues issues
  | maxSeverity issues == Just SeverityError = do
      printSummary issues
      liftIO exitFailure
  | otherwise = traverse_ injectIssue issues

unpackPath :: (Pkg, Maybe FilePath) -> ConfigT (Pkg, FilePath)
unpackPath (pkg, Just path) = pure (pkg, path)
unpackPath (pkg, Nothing) = throwError $ fromString $ "No file path found for package " <> toString (printPkgWSRef pkg)

data PublishOptions = PublishOptions
  { publishGroup :: Maybe Name,
    publishDryRun :: Bool
  }
  deriving (Show)

instance ParseCLI PublishOptions where
  parseCLI =
    PublishOptions
      <$> optional (argument str (metavar "GROUP" <> help "Name of the release group to publish (default: all)"))
      <*> switch (long "dry-run" <> help "Validate publish prerequisites and show the plan without uploading to Hackage")

arrangePackageRelease :: [Pkg] -> ConfigT [Pkg]
arrangePackageRelease pkgs = do
  graph <- deriveDependencyGraph
  sortByDependencyHierarchy graph pkgs

collectGroups :: Maybe Name -> ConfigT WsPkgs
collectGroups Nothing = do
  pbMap <- fromMaybe mempty . (>>= rlsPublish) <$> asks (cfgRelease . config)
  concat <$> traverse resolveWsPkgs (Map.elems pbMap)
collectGroups (Just name) = do
  pbMap <- fromMaybe mempty . (>>= rlsPublish) <$> asks (cfgRelease . config)
  case Map.lookup name pbMap of
    Just pbList -> resolveWsPkgs pbList
    Nothing -> throwError $ fromString $ toString $ "No publish configuration found for group \"" <> name <> "\". Check release configuration."

runPublish :: PublishOptions -> ConfigT ()
runPublish PublishOptions {..} = do
  wgs <- collectGroups publishGroup
  version <- askVersion
  when (null wgs) $ throwError "No publishable groups found. Check workspace group configuration."
  sectionTableM
    "publish"
    [ ("version", pure $ chalk Magenta (format version)),
      ("target", pure $ chalk Cyan (fromMaybe "all" publishGroup)),
      ("registry", pure "hackage"),
      ("mode", pure $ if publishDryRun then chalk Yellow "dry-run" else chalk Cyan "publish")
    ]

  pkgs <- arrangePackageRelease (concatMap snd wgs)

  sdists <- traverse nativeSdist pkgs
  failIssues (concatMap snd sdists)
  releasePkgs <- traverse (unpackPath . fst) sdists
  cwd <- liftIO getCurrentDirectory

  let ls = zip releasePkgs [1 ..] :: [((Pkg, FilePath), Int)]

  let size = genMaxLen (map (\((pkg, _), n) -> show n <> ". " <> printPkgWSRef pkg) ls)

  section_ "publishing plan (topological sort)" $ do
    for_ ls $ \((pkg, filePath), idx) -> do
      uiSubPathRow size (show idx <> ". " <> printPkgWSRef pkg) (format $ makeRelative cwd filePath)

  token <- getHackageToken
  if publishDryRun
    then section_ "publishing (dry-run)" $ do
      let _tokenUsed = token
      for_ releasePkgs $ \(pkg, _) -> uiSubPathRow size (printPkgWSRef pkg) (statusIcon Checked)
    else section_ "publishing" $ do
      for_ releasePkgs $ \pkg -> publishPackage size token pkg
  where
    publishPackage size token (pkg, filePath) = do
      issues <- uploadToHackage token pkg filePath
      let status = if null issues then Checked else Invalid
      uiSubPathRow size (printPkgWSRef pkg) (statusIcon status)
      failIssues issues