hwm 0.1.0 → 0.1.1

raw patch · 29 files changed

+317/−238 lines, 29 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hwm.cabal +5/−4
• src/HWM/CLI/App.hs +1/−1
• src/HWM/CLI/Command.hs +3/−3
• src/HWM/CLI/Command/Environment.hs +0/−42
• src/HWM/CLI/Command/Environment/Root.hs +42/−0
• src/HWM/CLI/Command/Init.hs +2/−1
• src/HWM/CLI/Command/Registry.hs +0/−39
• src/HWM/CLI/Command/Registry/Add.hs +1/−2
• src/HWM/CLI/Command/Registry/Audit.hs +2/−2
• src/HWM/CLI/Command/Registry/Root.hs +39/−0
• src/HWM/CLI/Command/Release/Artifacts.hs +38/−49
• src/HWM/CLI/Command/Release/Publish.hs +1/−2
• src/HWM/CLI/Command/Release/Root.hs +6/−2
• src/HWM/CLI/Command/Run.hs +2/−4
• src/HWM/CLI/Command/Status.hs +0/−1
• src/HWM/CLI/Command/Sync.hs +0/−2
• src/HWM/CLI/Command/Version.hs +1/−6
• src/HWM/CLI/Command/Workspace.hs +0/−34
• src/HWM/CLI/Command/Workspace/Add.hs +0/−1
• src/HWM/CLI/Command/Workspace/Root.hs +34/−0
• src/HWM/Core/Options.hs +6/−0
• src/HWM/Domain/Config.hs +1/−0
• src/HWM/Domain/Environments.hs +6/−5
• src/HWM/Domain/Release.hs +20/−0
• src/HWM/Integrations/Toolchain/Github.hs +25/−0
• src/HWM/Integrations/Toolchain/Stack.hs +2/−2
• src/HWM/Runtime/Logging.hs +10/−15
• src/HWM/Runtime/Network.hs +48/−1
• src/HWM/Runtime/UI.hs +22/−20

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hwm-version:        0.1.0+version:        0.1.1 synopsis:       Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS description:    HWM (Haskell Workspace Manager) manages multi-package Haskell projects by                 generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS@@ -32,16 +32,16 @@   exposed-modules:       HWM.CLI.App       HWM.CLI.Command-      HWM.CLI.Command.Environment       HWM.CLI.Command.Environment.Add       HWM.CLI.Command.Environment.Ls       HWM.CLI.Command.Environment.Remove+      HWM.CLI.Command.Environment.Root       HWM.CLI.Command.Environment.SetDefault       HWM.CLI.Command.Init-      HWM.CLI.Command.Registry       HWM.CLI.Command.Registry.Add       HWM.CLI.Command.Registry.Audit       HWM.CLI.Command.Registry.Ls+      HWM.CLI.Command.Registry.Root       HWM.CLI.Command.Release.Artifacts       HWM.CLI.Command.Release.Publish       HWM.CLI.Command.Release.Root@@ -49,9 +49,9 @@       HWM.CLI.Command.Status       HWM.CLI.Command.Sync       HWM.CLI.Command.Version-      HWM.CLI.Command.Workspace       HWM.CLI.Command.Workspace.Add       HWM.CLI.Command.Workspace.Ls+      HWM.CLI.Command.Workspace.Root       HWM.Core.Common       HWM.Core.Formatting       HWM.Core.Has@@ -69,6 +69,7 @@       HWM.Domain.Workspace       HWM.Integrations.Scaffold       HWM.Integrations.Toolchain.Cabal+      HWM.Integrations.Toolchain.Github       HWM.Integrations.Toolchain.Hie       HWM.Integrations.Toolchain.Lib       HWM.Integrations.Toolchain.Package

@@ -71,7 +71,7 @@         "Manage workspace groups and package members.",         Workspace <$> parseCLI       ),-      ( "environment",+      ( "environments",         "Manage GHC toolchains and resolver targets.",         Env <$> parseCLI       ),

@@ -12,15 +12,15 @@ where  import Data.Version (showVersion)-import HWM.CLI.Command.Environment (EnvCommand, runEnv)+import HWM.CLI.Command.Environment.Root (EnvCommand, runEnv) import HWM.CLI.Command.Init (InitOptions (..), initWorkspace)-import HWM.CLI.Command.Registry (RegistryCommand, runRegistry)+import HWM.CLI.Command.Registry.Root (RegistryCommand, runRegistry) import HWM.CLI.Command.Release.Root (ReleaseCommand (..), runRelease) import HWM.CLI.Command.Run (ScriptOptions, runScript) import HWM.CLI.Command.Status (showStatus) import HWM.CLI.Command.Sync (sync) import HWM.CLI.Command.Version (VersionOptions, runVersion)-import HWM.CLI.Command.Workspace (WorkspaceCommand, runWorkspace)+import HWM.CLI.Command.Workspace.Root (WorkspaceCommand, runWorkspace) import HWM.Core.Common (Name) import HWM.Core.Options (Options (..), defaultOptions) import HWM.Core.Version (Bump (..))

@@ -1,42 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module HWM.CLI.Command.Environment-  ( EnvCommand (..),-    runEnv,-  )-where--import HWM.CLI.Command.Environment.Add (EnvAddOptions, runEnvAdd)-import HWM.CLI.Command.Environment.Ls (EnvLsOptions, runEnvLs)-import HWM.CLI.Command.Environment.Remove (EnvRemoveOptions, runEnvRemove)-import HWM.CLI.Command.Environment.SetDefault (EnvSetDefaultOptions, runEnvSetDefault)-import HWM.Core.Parsing (ParseCLI (..))-import HWM.Domain.ConfigT (ConfigT)-import Options.Applicative (command, info, progDesc, subparser)-import Relude---- | Subcommands for `hwm environment`-data EnvCommand-  = EnvAdd EnvAddOptions-  | EnvRemove EnvRemoveOptions-  | EnvSetDefault EnvSetDefaultOptions-  | EnvLs EnvLsOptions-  deriving (Show)--runEnv :: EnvCommand -> ConfigT ()-runEnv cmd = case cmd of-  EnvAdd opts -> runEnvAdd opts-  EnvRemove opts -> runEnvRemove opts-  EnvSetDefault opts -> runEnvSetDefault opts-  EnvLs opts -> runEnvLs opts--instance ParseCLI EnvCommand where-  parseCLI =-    subparser-      ( mconcat-          [ command "add" (info (EnvAdd <$> parseCLI) (progDesc "Add a new environment.")),-            command "remove" (info (EnvRemove <$> parseCLI) (progDesc "Remove an environment.")),-            command "set-default" (info (EnvSetDefault <$> parseCLI) (progDesc "Set the default environment.")),-            command "ls" (info (EnvLs <$> parseCLI) (progDesc "List all environments."))-          ]-      )

@@ -0,0 +1,42 @@+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Environment.Root+  ( EnvCommand (..),+    runEnv,+  )+where++import HWM.CLI.Command.Environment.Add (EnvAddOptions, runEnvAdd)+import HWM.CLI.Command.Environment.Ls (EnvLsOptions, runEnvLs)+import HWM.CLI.Command.Environment.Remove (EnvRemoveOptions, runEnvRemove)+import HWM.CLI.Command.Environment.SetDefault (EnvSetDefaultOptions, runEnvSetDefault)+import HWM.Core.Parsing (ParseCLI (..))+import HWM.Domain.ConfigT (ConfigT)+import Options.Applicative (command, info, progDesc, subparser)+import Relude++-- | Subcommands for `hwm environment`+data EnvCommand+  = EnvAdd EnvAddOptions+  | EnvRemove EnvRemoveOptions+  | EnvSetDefault EnvSetDefaultOptions+  | EnvLs EnvLsOptions+  deriving (Show)++runEnv :: EnvCommand -> ConfigT ()+runEnv cmd = case cmd of+  EnvAdd opts -> runEnvAdd opts+  EnvRemove opts -> runEnvRemove opts+  EnvSetDefault opts -> runEnvSetDefault opts+  EnvLs opts -> runEnvLs opts++instance ParseCLI EnvCommand where+  parseCLI =+    subparser+      ( mconcat+          [ command "add" (info (EnvAdd <$> parseCLI) (progDesc "Add a new environment.")),+            command "remove" (info (EnvRemove <$> parseCLI) (progDesc "Remove an environment.")),+            command "set-default" (info (EnvSetDefault <$> parseCLI) (progDesc "Set the default environment.")),+            command "ls" (info (EnvLs <$> parseCLI) (progDesc "List all environments."))+          ]+      )

@@ -64,7 +64,8 @@     cfgWorkspace <- buildWorkspace graph pkgs     saveConfig       Config-        { cfgBounds = Nothing,+        { cfgGithub = Nothing,+          cfgBounds = Nothing,           cfgScripts = defaultScripts,           cfgRelease = Nothing,           ..

@@ -1,39 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module HWM.CLI.Command.Registry-  ( RegistryCommand (..),-    runRegistry,-  )-where--import HWM.CLI.Command.Registry.Add (RegistryAddOptions, runRegistryAdd)-import HWM.CLI.Command.Registry.Audit (RegistryAuditOptions, runRegistryAudit)-import HWM.CLI.Command.Registry.Ls (RegistryLsOptions, runRegistryLs)-import HWM.Core.Parsing (ParseCLI (..))-import HWM.Domain.ConfigT (ConfigT)-import Options.Applicative (command, info, progDesc, subparser)-import Relude---- | Subcommands for `hwm registry`-data RegistryCommand-  = RegistryAdd RegistryAddOptions-  | RegistryAudit RegistryAuditOptions-  | RegistryLs RegistryLsOptions-  deriving (Show)--runRegistry :: RegistryCommand -> ConfigT ()-runRegistry registryCommand =-  case registryCommand of-    RegistryAdd opts -> runRegistryAdd opts-    RegistryAudit opts -> runRegistryAudit opts-    RegistryLs opts -> runRegistryLs opts--instance ParseCLI RegistryCommand where-  parseCLI =-    subparser-      ( mconcat-          [ command "add" (info (RegistryAdd <$> parseCLI) (progDesc "Add a dependency to the registry.")),-            command "audit" (info (RegistryAudit <$> parseCLI) (progDesc "Audit and optionally fix the registry.")),-            command "ls" (info (RegistryLs <$> parseCLI) (progDesc "List registry entries."))-          ]-      )

@@ -31,7 +31,6 @@ runRegistryAdd RegistryAddOptions {opsPkgName, opsWorkspace} = do   workspaces <- resolveWorkspaces opsWorkspace   sectionTableM-    0     "add dependency"     [ ("package", pure $ chalk Magenta (format opsPkgName)),       ("target", pure $ chalk Cyan (if null opsWorkspace then "none (registry only)" else T.intercalate ", " opsWorkspace))@@ -47,7 +46,7 @@       let dependency = Dependency opsPkgName bounds        ((\cf -> pure cf {cfgRegistry = cfgRegistry cf <> singleDeps dependency}) `updateConfig`) $ do-        sectionConfig 0 [("hwm.yaml", pure $ chalk Green "✓")]+        sectionConfig [("hwm.yaml", pure $ chalk Green "✓")]         addDepToPackage workspaces dependency     Just bounds -> do       section "discovery" $ do

@@ -29,7 +29,7 @@ runRegistryAudit RegistryAuditOptions {..} = do   originalRegistry <- asks (cfgRegistry . config)   range <- getTestedRange-  sectionTableM 16 "audit" [("mode", pure (if auditFix then if auditForce then chalk Yellow "fix (force)" else chalk Cyan "fix" else "check"))]+  sectionTableM "audit" [("mode", pure (if auditFix then if auditForce then chalk Yellow "fix (force)" else chalk Cyan "fix" else "check"))]    let dependencyAudits = filter (auditHasAny (/= Valid)) $ mapWithName (auditBounds range) originalRegistry   section "registry" $ printGenTable $ formatAudit <$> dependencyAudits@@ -41,7 +41,7 @@     else do       if auditFix         then ((\cf -> pure $ cf {cfgRegistry = mapDeps (updateDepBounds auditForce range) originalRegistry}) `updateConfig`) $ do-          sectionConfig 0 [("hwm.yaml", pure $ chalk Green "✓")]+          sectionConfig [("hwm.yaml", pure $ chalk Green "✓")]           syncPackages         else do           injectIssue

@@ -0,0 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Registry.Root+  ( RegistryCommand (..),+    runRegistry,+  )+where++import HWM.CLI.Command.Registry.Add (RegistryAddOptions, runRegistryAdd)+import HWM.CLI.Command.Registry.Audit (RegistryAuditOptions, runRegistryAudit)+import HWM.CLI.Command.Registry.Ls (RegistryLsOptions, runRegistryLs)+import HWM.Core.Parsing (ParseCLI (..))+import HWM.Domain.ConfigT (ConfigT)+import Options.Applicative (command, info, progDesc, subparser)+import Relude++-- | Subcommands for `hwm registry`+data RegistryCommand+  = RegistryAdd RegistryAddOptions+  | RegistryAudit RegistryAuditOptions+  | RegistryLs RegistryLsOptions+  deriving (Show)++runRegistry :: RegistryCommand -> ConfigT ()+runRegistry registryCommand =+  case registryCommand of+    RegistryAdd opts -> runRegistryAdd opts+    RegistryAudit opts -> runRegistryAudit opts+    RegistryLs opts -> runRegistryLs opts++instance ParseCLI RegistryCommand where+  parseCLI =+    subparser+      ( mconcat+          [ command "add" (info (RegistryAdd <$> parseCLI) (progDesc "Add a dependency to the registry.")),+            command "audit" (info (RegistryAudit <$> parseCLI) (progDesc "Audit and optionally fix the registry.")),+            command "ls" (info (RegistryLs <$> parseCLI) (progDesc "List registry entries."))+          ]+      )

@@ -13,7 +13,6 @@ where  import Control.Monad.Except (MonadError (..))-import qualified Data.Map as Map import qualified Data.Text as T import Data.Traversable (for) import HWM.Core.Common (Name)@@ -23,13 +22,14 @@ import HWM.Core.Result (fromEither) import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, Env (..), getArchiveConfigs)-import HWM.Domain.Release (ArchiveFormat, ArtifactConfig (..))+import HWM.Domain.Release (ArchiveFormat, ArtifactConfig (..), ReleaseArtifactConfigs, selectedArtifacts) import HWM.Domain.Workspace (resolveWorkspaces)+import HWM.Integrations.Toolchain.Github (ensureIsLatestTag) import HWM.Integrations.Toolchain.Stack (stackGenBinary) import HWM.Runtime.Archive (ArchiveInfo (..), ArchivingPlan (..), createArchive)-import HWM.Runtime.Network (uploadToGitHub)-import HWM.Runtime.UI (indent, mapMTable, putLine, section, sectionTableM)-import Options.Applicative (help, long, metavar, option, showDefault, str, strOption, value)+import HWM.Runtime.Network (getGHUploadUrl, uploadToGitHub)+import HWM.Runtime.UI (forTable, indent, putLine, section, sectionTableM)+import Options.Applicative (argument, help, long, metavar, option, showDefault, str, strOption, switch, value) import Relude import System.Directory (createDirectoryIfMissing, removePathForcibly) import System.FilePath (joinPath)@@ -37,39 +37,29 @@ -- | Options for 'hwm release archive' data ReleaseArchiveOptions = ReleaseArchiveOptions   { targetName :: Maybe Text,-    ghPublishUrl :: Maybe Text,+    ghPublish :: Bool,     outputDir :: FilePath,     ovFormat :: Maybe [Text],-    overrides :: ArchiveOverrides-  }-  deriving (Show)--data ArchiveOverrides = ArchiveOverrides-  { ovGhcOptions :: Maybe [Text],+    ovGhcOptions :: Maybe [Text],     ovNameTemplate :: Maybe Text   }   deriving (Show) -instance ParseCLI ArchiveOverrides where-  parseCLI =-    ArchiveOverrides-      <$> optional (option (parseLS <$> str) (long "ghc-options" <> metavar "GHC_OPTION" <> help "Override GHC options for the release target. Can be specified multiple times."))-      <*> optional (strOption (long "name-template" <> metavar "NAME_TEMPLATE" <> help "Override the name template for the release target. Use {name} and {version} as placeholders."))- instance ParseCLI ReleaseArchiveOptions where   parseCLI =     ReleaseArchiveOptions-      <$> optional (strOption (long "target" <> metavar "TARGET" <> help "Name of the release target to build. If not specified, all targets will be built."))-      <*> optional (strOption (long "gh-upload" <> metavar "UPLOAD_URL" <> help "URL to upload the release artifact. If not specified, the artifact will not be uploaded."))+      <$> optional (argument str (metavar "TARGET" <> help "Name of the release target to build (default: all)"))+      <*> switch (long "github" <> help "Upload generated artifacts to a GitHub Release")       <*> strOption         ( long "output-dir"             <> metavar "OUTPUT_DIR"             <> help "Directory to output the release artifacts."-            <> value ".hwm/dist"+            <> value defaultOutputDir             <> showDefault         )       <*> optional (option (parseLS <$> str) (long "format" <> metavar "FORMAT" <> help "Override the archive format for the release target. Supported: zip, tar.gz."))-      <*> parseCLI+      <*> optional (option (parseLS <$> str) (long "ghc-options" <> metavar "GHC_OPTION" <> help "Override GHC options for the release target. Can be specified multiple times."))+      <*> optional (strOption (long "name-template" <> metavar "NAME_TEMPLATE" <> help "Override the name template for the release target. Use {name} and {version} as placeholders."))  genBindaryDir :: (MonadIO m, ToString a) => a -> m FilePath genBindaryDir name = do@@ -81,44 +71,45 @@ ghcOptions [] = [] ghcOptions xs = ["--ghc-options=" <> T.unwords xs] +defaultOutputDir :: FilePath+defaultOutputDir = ".hwm/dist"+ prepeareDir :: (MonadIO m) => FilePath -> m () prepeareDir dir = liftIO $ do   removePathForcibly dir   createDirectoryIfMissing True dir -applyOverrieds :: Maybe [ArchiveFormat] -> ArchiveOverrides -> ArtifactConfig -> ArtifactConfig-applyOverrieds formats ArchiveOverrides {..} cfg =-  cfg-    { arcFormats = fromMaybe (arcFormats cfg) formats,-      arcGhcOptions = fromMaybe (arcGhcOptions cfg) ovGhcOptions,-      arcNameTemplate = fromMaybe (arcNameTemplate cfg) ovNameTemplate-    }- parseFormats :: [Text] -> ConfigT [ArchiveFormat] parseFormats = fromEither "can't parse archive format" . traverse parse -withOverrides :: ReleaseArchiveOptions -> Map Name ArtifactConfig -> ConfigT [(Name, ArtifactConfig)]+withOverrides :: ReleaseArchiveOptions -> ReleaseArtifactConfigs -> ConfigT [(Name, ArtifactConfig)] withOverrides ReleaseArchiveOptions {..} cfgs = do   parsedFormats <- traverse parseFormats ovFormat-  case targetName of-    Just target -> case Map.lookup target cfgs of-      Just cfg -> pure [(target, applyOverrieds parsedFormats overrides cfg)]-      Nothing -> throwError $ fromString $ "Target \"" <> toString target <> "\" not found in configuration."-    Nothing -> pure $ map (second (applyOverrieds parsedFormats overrides)) (Map.toList cfgs)+  map (second (applyOverrieds parsedFormats)) <$> selectedArtifacts targetName cfgs+  where+    applyOverrieds formats cfg =+      cfg+        { arcFormats = fromMaybe (arcFormats cfg) formats,+          arcGhcOptions = fromMaybe (arcGhcOptions cfg) ovGhcOptions,+          arcNameTemplate = fromMaybe (arcNameTemplate cfg) ovNameTemplate+        }  runReleaseArchive :: ReleaseArchiveOptions -> ConfigT () runReleaseArchive ops@ReleaseArchiveOptions {..} = do-  prepeareDir outputDir+  prepeareDir defaultOutputDir+  cfg <- asks config   version <- asks (cfgVersion . config)   cfgs <- getArchiveConfigs >>= withOverrides ops+  ghTag <- if ghPublish then Just <$> ensureIsLatestTag version else pure Nothing+  uploadUrl <- maybe (pure Nothing) (fmap Just . getGHUploadUrl cfg) ghTag -  sectionTableM 0 "artifacts"-    $ [ ("mode", pure $ if isNothing ghPublishUrl then "local" else "publish to GitHub"),-        ("output directory", pure $ T.pack outputDir),+  sectionTableM "artifacts"+    $ [ ("destination", pure $ maybe (format outputDir) format uploadUrl),+        ("version", pure $ format version <> maybe "" (\tag -> " (GitHub Release " <> tag <> ")") ghTag),         ("targets", pure $ formatList "," (map fst cfgs))       ] -  plans <- mapMTable "build" $ map (\x -> (fst x, buildPkg x)) cfgs+  plans <- forTable "build" cfgs (\x -> (fst x, buildPkg x))    section "archive" $ pure ()   artifacts <- for plans $ \(name, plan) -> do@@ -131,15 +122,13 @@         putLine $ subPathSign <> format sha256Path     pure (name, archives) -  for_ ghPublishUrl $ \uploadUrl -> section "publish (github)"+  for_ uploadUrl $ \url -> section "publish (Github)"     $ for_ artifacts-    $ \(name, archives) -> section name-      $ for_ archives-      $ \ArchiveInfo {..} -> do-        uploadToGitHub uploadUrl archivePath-        putLine "gh published"-        uploadToGitHub uploadUrl sha256Path-        putLine "checksum published"+    $ \(name, archives) -> section name $ for_ archives $ \ArchiveInfo {..} -> do+      uploadToGitHub url archivePath+      putLine $ subPathSign <> format archivePath+      uploadToGitHub url sha256Path+      putLine $ subPathSign <> format sha256Path   where     buildPkg (name, ArtifactConfig {..}) = do       binaryDir <- genBindaryDir name

@@ -49,7 +49,7 @@ instance ParseCLI PublishOptions where   parseCLI =     PublishOptions-      <$> optional (argument str (metavar "GROUP" <> help "Name of the workspace group to publish (default: all)"))+      <$> optional (argument str (metavar "GROUP" <> help "Name of the release group to publish (default: all)"))  arrangePackageRelease :: [Pkg] -> ConfigT [Pkg] arrangePackageRelease pkgs = do@@ -72,7 +72,6 @@   version <- askVersion   when (null wgs) $ throwError "No publishable groups found. Check workspace group configuration."   sectionTableM-    0     "publish"     [ ("version", pure $ chalk Magenta (format version)),       ("target", pure $ chalk Cyan (fromMaybe "all" publishGroup)),

@@ -23,8 +23,12 @@ instance ParseCLI ReleaseCommand where   parseCLI =     hsubparser-      ( command "artifacts" (info (ReleaseArchive <$> parseCLI) (progDesc "Build, archive, hash, and export a package release"))-          <> command "publish" (info (Publish <$> parseCLI) (progDesc "Publish a package release to Hackage"))+      ( command+          "artifacts"+          (info (ReleaseArchive <$> parseCLI) (progDesc "Generate, bundle, and upload release artifacts"))+          <> command+            "publish"+            (info (Publish <$> parseCLI) (progDesc "Publish the workspace packages to Hackage"))       )  runRelease :: ReleaseCommand -> ConfigT ()

@@ -25,8 +25,7 @@ import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment, getBuildEnvironments) import HWM.Domain.Workspace (resolveWorkspaces) import HWM.Integrations.Toolchain.Stack (createEnvYaml, stackPath)-import HWM.Runtime.Cache (prepareDir)-import HWM.Runtime.Logging (logError, logRoot)+import HWM.Runtime.Logging (logIssue) import HWM.Runtime.Process (inheritRun, silentRun) import HWM.Runtime.UI (putLine, runSpinner, sectionEnvironments, sectionWorkspace, statusIndicator) import Options.Applicative@@ -59,7 +58,6 @@  runScript :: Name -> ScriptOptions -> ConfigT () runScript scriptName ScriptOptions {..} = do-  prepareDir logRoot   cfg <- asks config   case M.lookup scriptName (cfgScripts cfg) of     Just script -> do@@ -92,7 +90,7 @@       (success, content) <- silentRun yamlPath cmd (async (runSpinner padding env))       statusIndicator padding env (statusIcon (if success then Checked else Invalid))       unless success $ do-        path <- logError buildName [("ENVIRONMENT", format benv), ("COMMAND", format cmd)] content+        path <- logIssue buildName SeverityError [("ENVIRONMENT", format benv), ("COMMAND", format cmd)] content         throwError           Issue             { issueTopic = buildName,

@@ -17,7 +17,6 @@ showStatus = do   cfg <- asks config   sectionTableM-    0     "project"     [ ("name", pure $ chalk Magenta (cfgName cfg)),       ("version", pure $ chalk Green (format $ cfgVersion cfg))

@@ -19,13 +19,11 @@   env <- getBuildEnvironment tag   updateRegistry $ \reg -> reg {currentEnv = buildName env}   sectionTableM-    0     "sync"     [ ("enviroment", pure $ chalk Cyan $ format env),       ("resolver", pure $ buildResolver env)     ]   sectionConfig-    0     [ ("stack.yaml", syncStackYaml $> chalk Green "✓"),       ("hie.yaml", syncHie $> chalk Green "✓")     ]

@@ -20,9 +20,6 @@ import Options.Applicative.Builder (str) import Relude -size :: Int-size = 16- newtype VersionOptions = VersionOptions {bump :: Maybe VersionChange} deriving (Show)  instance ParseCLI VersionOptions where@@ -32,7 +29,6 @@ bumpVersion (BumpVersion bump) Config {..} = do   let version' = nextVersion bump cfgVersion   sectionTableM-    size     ("bump version (" <> format bump <> ")")     [ ("from", pure $ format cfgVersion),       ("to", pure $ chalk Cyan (format version'))@@ -40,7 +36,6 @@   pure Config {cfgVersion = version', cfgBounds = Nothing, ..} bumpVersion (FixedVersion version') Config {..} = do   sectionTableM-    size     "set version"     [ ("from", pure $ format cfgVersion),       ("to", pure $ chalk Cyan (format version') <> if version' == cfgVersion then " (no change)" else "")@@ -60,7 +55,7 @@  runVersion :: VersionOptions -> ConfigT () runVersion (VersionOptions (Just bump)) = (bumpVersion bump `updateConfig`) $ do-  sectionConfig size [("hwm.yaml", pure $ chalk Green "✓")]+  sectionConfig [("hwm.yaml", pure $ chalk Green "✓")]   syncPackages runVersion (VersionOptions Nothing) = do   putLine . format . cfgVersion =<< asks config

@@ -1,34 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module HWM.CLI.Command.Workspace-  ( WorkspaceCommand (..),-    runWorkspace,-  )-where--import HWM.CLI.Command.Workspace.Add (WorkspaceAddOptions, runWorkspaceAdd)-import HWM.CLI.Command.Workspace.Ls (WorkspaceLsOptions, runWorkspaceLs)-import HWM.Core.Parsing (ParseCLI (..))-import HWM.Domain.ConfigT (ConfigT)-import Options.Applicative (command, info, progDesc, subparser)-import Relude---- | Subcommands for `hwm workspace`-data WorkspaceCommand-  = WorkspaceAdd WorkspaceAddOptions-  | WorkspaceLs WorkspaceLsOptions-  deriving (Show)--runWorkspace :: WorkspaceCommand -> ConfigT ()-runWorkspace cmd = case cmd of-  WorkspaceAdd opts -> runWorkspaceAdd opts-  WorkspaceLs opts -> runWorkspaceLs opts--instance ParseCLI WorkspaceCommand where-  parseCLI =-    subparser-      ( mconcat-          [ command "add" (info (WorkspaceAdd <$> parseCLI) (progDesc "Add a new workspace.")),-            command "ls" (info (WorkspaceLs <$> parseCLI) (progDesc "List all workspaces."))-          ]-      )

@@ -62,7 +62,6 @@       putLine $ "• " <> chalk Bold groupId       putLine $ subPathSign <> padDots 16 memberId <> displayStatus [("added", Checked)]       sectionConfig-        0         [ ("stack.yaml", syncStackYaml $> chalk Green "✓"),           ("hie.yaml", syncHie $> chalk Green "✓")         ]

@@ -0,0 +1,34 @@+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Workspace.Root+  ( WorkspaceCommand (..),+    runWorkspace,+  )+where++import HWM.CLI.Command.Workspace.Add (WorkspaceAddOptions, runWorkspaceAdd)+import HWM.CLI.Command.Workspace.Ls (WorkspaceLsOptions, runWorkspaceLs)+import HWM.Core.Parsing (ParseCLI (..))+import HWM.Domain.ConfigT (ConfigT)+import Options.Applicative (command, info, progDesc, subparser)+import Relude++-- | Subcommands for `hwm workspace`+data WorkspaceCommand+  = WorkspaceAdd WorkspaceAddOptions+  | WorkspaceLs WorkspaceLsOptions+  deriving (Show)++runWorkspace :: WorkspaceCommand -> ConfigT ()+runWorkspace cmd = case cmd of+  WorkspaceAdd opts -> runWorkspaceAdd opts+  WorkspaceLs opts -> runWorkspaceLs opts++instance ParseCLI WorkspaceCommand where+  parseCLI =+    subparser+      ( mconcat+          [ command "add" (info (WorkspaceAdd <$> parseCLI) (progDesc "Add a new workspace.")),+            command "ls" (info (WorkspaceLs <$> parseCLI) (progDesc "List all workspaces."))+          ]+      )

@@ -5,6 +5,7 @@   ( Options (..),     defaultOptions,     askOptions,+    whenCI,   ) where @@ -29,3 +30,8 @@       stack = "./stack.yaml",       quiet = False     }++whenCI :: (MonadIO m) => m () -> m ()+whenCI action = do+  ci <- liftIO $ isJust <$> lookupEnv "CI"+  when ci action

@@ -34,6 +34,7 @@  data Config = Config   { cfgName :: Name,+    cfgGithub :: Maybe Text,     cfgVersion :: Version,     cfgBounds :: Maybe Bounds,     cfgWorkspace :: Workspace,

@@ -49,7 +49,7 @@ import HWM.Domain.Workspace (Workspace, allPackages) import HWM.Runtime.Cache (Cache, Registry (currentEnv), VersionMap, getLatestNightlySnapshot, getRegistry, getSnapshot, getVersions) import HWM.Runtime.Files (aesonYAMLOptions, aesonYAMLOptionsAdvanced)-import HWM.Runtime.UI (MonadUI, forTable, sectionEnvironments)+import HWM.Runtime.UI (MonadUI, forTable_, sectionEnvironments) import Relude  type Extras = VersionMap@@ -245,11 +245,12 @@   active <- getBuildEnvironment name   def <- envDefault <$> askEnv   environments <- getBuildEnvironments-  sectionEnvironments (Just $ format def) $ forTable 0 environments $ \env ->+  sectionEnvironments (Just $ format def) $ forTable_ environments $ \env ->     ( format env,-      if env == active-        then chalk Cyan (buildResolver env <> " (active)")-        else chalk Gray (buildResolver env)+      pure+        $ if env == active+          then chalk Cyan (buildResolver env <> " (active)")+          else chalk Gray (buildResolver env)     )  getTestedRange :: (Monad m, MonadReader env m, Has env Workspace, Has env Environments, MonadIO m, MonadError Issue m) => m TestedRange

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -7,19 +8,25 @@     ArtifactConfig (..),     ArchiveFormat (..),     formatArchiveTemplate,+    ReleaseArtifactConfigs,+    getArtifact,+    selectedArtifacts,   ) where +import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson   ( FromJSON (..),     ToJSON (toJSON),     genericParseJSON,     genericToJSON,   )+import qualified Data.Map as Map import Data.Yaml (Value (..)) import HWM.Core.Common (Name) import HWM.Core.Formatting (Format (..), formatTemplate) import HWM.Core.Parsing (Parse (..))+import HWM.Core.Result (Issue) import HWM.Core.Version (Version) import HWM.Domain.Workspace (WorkspaceRef) import HWM.Runtime.Files (aesonYAMLOptionsAdvanced)@@ -45,6 +52,19 @@  instance ToJSON Release where   toJSON = genericToJSON (aesonYAMLOptionsAdvanced prefix)++type ReleaseArtifactConfigs = Map Name ArtifactConfig++getArtifact :: (MonadError Issue m) => Name -> ReleaseArtifactConfigs -> m ArtifactConfig+getArtifact name cfgs = case Map.lookup name cfgs of+  Just cfg -> pure cfg+  Nothing -> throwError $ fromString $ "Artifact \"" <> toString name <> "\" not found in release configuration."++selectedArtifacts :: (MonadError Issue m) => Maybe Name -> ReleaseArtifactConfigs -> m [(Name, ArtifactConfig)]+selectedArtifacts (Just target) cfgs = do+  cfg <- getArtifact target cfgs+  pure [(target, cfg)]+selectedArtifacts Nothing cfgs = pure $ Map.toList cfgs  data ArtifactConfig = ArtifactConfig   { arcSource :: Text,

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Github (ensureIsLatestTag) where++import Control.Monad.Error.Class (MonadError (..))+import qualified Data.Text as T+import HWM.Core.Formatting (Format (format))+import HWM.Core.Result (Issue)+import HWM.Core.Version (Version)+import Relude+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)++ensureIsLatestTag :: (MonadIO m, MonadError Issue m) => Version -> m Text+ensureIsLatestTag targetTag = do+  (exitCode, out, _err) <- liftIO $ readProcessWithExitCode "git" ["describe", "--tags", "--abbrev=0"] ""+  case exitCode of+    ExitSuccess -> do+      let latestTag = T.strip (T.pack out)+      if latestTag == format targetTag || latestTag == "v" <> format targetTag+        then pure latestTag+        else throwError $ fromString $ toString ("Safety abort! You are trying to upload to an older release '" <> format targetTag <> "', but your latest tag is actually '" <> latestTag <> "'.")+    ExitFailure _ -> throwError $ fromString "Safety abort! Could not find any tags in the current Git history."

@@ -43,7 +43,7 @@ import HWM.Domain.Environments (BuildEnvironment (..), EnviromentTarget (..), Environments (..), getBuildEnvironment, hkgRefs) import HWM.Runtime.Cache (getSnapshotGHC) import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_)-import HWM.Runtime.Logging (log)+import HWM.Runtime.Logging (logIssue) import HWM.Runtime.Process (exec) import Relude hiding (head, tail) import System.Directory (createDirectoryIfMissing, doesFileExist)@@ -138,7 +138,7 @@   case severity of     Nothing -> pure []     Just issueSeverity -> do-      issueFile <- log "sdist" [("COMMAND", "stack sdist " <> format (pkgName pkg)), ("SEVERITY", show issueSeverity)] (pack out)+      issueFile <- logIssue "sdist" issueSeverity [("COMMAND", "stack sdist " <> format (pkgName pkg))] (pack out)       let issueDetails = Just GenericIssue {issueFile}        in pure [Issue {..}] 

@@ -2,18 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module HWM.Runtime.Logging-  ( logRoot,-    logPath,-    log,-    logError,-  )-where+module HWM.Runtime.Logging (logIssue) where  import Data.Time (getCurrentTime) import HWM.Core.Common (Name)+import HWM.Core.Options (whenCI)+import HWM.Core.Result (Severity)+import HWM.Runtime.Cache (prepareDir)+import HWM.Runtime.UI (MonadUI, putLine) import Relude-import System.Directory (createDirectoryIfMissing) import qualified System.IO as TIO  logRoot :: FilePath@@ -22,18 +19,16 @@ logPath :: Name -> FilePath logPath name = logRoot <> "/" <> toString name <> ".log" -log :: (MonadIO m) => Name -> [(Text, Text)] -> Text -> m FilePath-log name table content = do+logIssue :: (MonadIO m, MonadUI m) => Name -> Severity -> [(Text, Text)] -> Text -> m FilePath+logIssue name severity table content = do+  prepareDir logRoot   timestamp <- liftIO getCurrentTime-  let logInfo = [("TIMESTAMP", show timestamp)]+  let logInfo = [("TIMESTAMP", show timestamp), ("SEVERITY", show severity)]   let path = logPath name-  liftIO $ createDirectoryIfMissing True logRoot   let boxTop = "┌──────────────────────────────────────────────────────────"       boxBottom = "└──────────────────────────────────────────────────────────"       rows = map (\(k, v) -> "│ " <> k <> ": " <> v) (table <> logInfo)       header = unlines (boxTop : rows <> [boxBottom, "", content, ""])   liftIO $ TIO.appendFile path (toString header)+  whenCI $ putLine content   pure path--logError :: (MonadIO m) => Name -> [(Text, Text)] -> Text -> m FilePath-logError name table = log name (table <> [("TYPE", "ERROR")])

@@ -1,13 +1,17 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} -module HWM.Runtime.Network (uploadToGitHub) where+module HWM.Runtime.Network (uploadToGitHub, getGHUploadUrl) where  import Control.Monad.Except (MonadError (..))+import Data.Aeson (FromJSON) import qualified Data.Text as T import HWM.Core.Result (Issue (..))+import HWM.Domain.Config (Config (..)) import Network.HTTP.Req import Relude import System.FilePath (takeFileName)@@ -42,3 +46,46 @@                 <> header "User-Agent" "hwm-tool" -- GitHub requires a User-Agent             )       Nothing -> liftIO $ putStrLn "GitHub Upload URLs must be HTTPS"++-- 1. Define a tiny data type to represent the GitHub JSON response.+-- Aeson automatically maps the "upload_url" JSON key to this record field.++data GitHubRelease = GitHubRelease+  { name :: Text,+    upload_url :: Text+  }+  deriving (Show, Generic)++-- 2. Automatically derive the JSON parser+instance FromJSON GitHubRelease++-- 3. The main function returning the clean URL+getGHUploadUrl :: (MonadIO m, MonadError Issue m) => Config -> Text -> m Text+getGHUploadUrl Config {..} tag = do+  gh <- maybe (throwError "GitHub repository not configured") pure cfgGithub+  token <- getGitHubToken+  liftIO $ runReq defaultHttpConfig $ do+    -- Construct the endpoint URL+    let urlStr = "https://api.github.com/repos/" <> gh <> "/releases/tags/" <> tag+    uri <- liftIO $ mkURI urlStr+    case useHttpsURI uri of+      Just (url, opts) -> do+        -- Execute the GET request, expecting a JSON response matching our GitHubRelease type+        r <-+          req+            GET+            url+            NoReqBody+            jsonResponse -- This automatically parses the ByteString into our GitHubRelease data type!+            ( opts+                <> header "Authorization" ("Bearer " <> encodeUtf8 token)+                <> header "Accept" "application/vnd.github+json"+                <> header "User-Agent" "hwm-tool"+            )++        -- Extract the raw URL from the parsed JSON object+        let rawUrl = upload_url (responseBody r)++        -- Strip the "{?name,label}" template suffix before returning+        return $ T.takeWhile (/= '{') rawUrl+      Nothing -> error "GitHub API URLs must be HTTPS"

@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -19,12 +20,12 @@     sectionEnvironments,     sectionConfig,     sectionTableM,-    forTable,+    forTable_,     printSummary,     statusIndicator,     runSpinner,     printGenTable,-    mapMTable,+    forTable,   ) where @@ -111,32 +112,33 @@ sectionEnvironments :: (MonadUI m) => Maybe Text -> m a -> m () sectionEnvironments title = section ("environments" <> maybe "" (\name -> chalk Dim " (default: " <> chalk Magenta name <> chalk Dim ")") title) -tableM :: (MonadUI m) => Int -> [(Text, m Text)] -> m ()-tableM minSize rows = traverse_ formatRow rows-  where-    maxLabelLen = maximum (minSize : map (T.length . fst) rows) + 2-    formatRow (label, valueM) = do-      value <- valueM-      putLine $ padDots maxLabelLen label <> value--sectionTableM :: (MonadUI m) => Int -> Text -> [(Text, m Text)] -> m ()-sectionTableM size title = section title . tableM size+minRawSize :: Int+minRawSize = 16 -mapMTable :: (MonadUI m) => Text -> [(Name, m (Text, a))] -> m [(Name, a)]-mapMTable title rows = sectionBase "•" title $ traverse formatRow rows+forHLTable :: (MonadUI m) => [a] -> (a -> (Name, m (Name, b))) -> m [(Name, b)]+forHLTable as f = traverse formatRow rows   where-    maxLabelLen = maximum (0 : map (T.length . fst) rows) + 2+    rows = map f as+    maxLabelLen = maximum (minRawSize : map (T.length . fst) rows) + 2     formatRow (label, valueM) = do       (value, mvalue) <- valueM       putLine $ padDots maxLabelLen label <> value       pure (label, mvalue) -sectionConfig :: (MonadUI m) => Int -> [(Text, m Text)] -> m ()-sectionConfig size = section "config" . tableM size+forTable :: (MonadUI m) => Name -> [a] -> (a -> (Name, m (Name, b))) -> m [(Name, b)]+forTable title as f = sectionBase "•" title $ forHLTable as f -forTable :: (MonadUI m) => Int -> [a] -> (a -> (Text, Text)) -> m ()-forTable minSize rows f =-  tableM minSize (map (second pure . f) rows)+forTable_ :: (MonadUI m) => [a] -> (a -> (Text, m Text)) -> m ()+forTable_ rows f = tableM_ (map f rows)++tableM_ :: (MonadUI m) => [(Text, m Text)] -> m ()+tableM_ rows = forHLTable rows (second ((,()) <$>)) $> ()++sectionTableM :: (MonadUI m) => Text -> [(Text, m Text)] -> m ()+sectionTableM title = section title . tableM_++sectionConfig :: (MonadUI m) => [(Text, m Text)] -> m ()+sectionConfig = section "config" . tableM_  printGenTable :: (MonadUI m) => [[Text]] -> m () printGenTable rows =