diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hwm.cabal b/hwm.cabal --- a/hwm.cabal +++ b/hwm.cabal @@ -1,199 +1,166 @@ -cabal-version: 1.12 -name: hwm -version: 0.2.0 -license: MIT -license-file: LICENSE -copyright: (c) 2026 Daviti Nalchevanidze -maintainer: d.nalchevanidze@gmail.com -author: Daviti Nalchevanidze -homepage: https://github.com/nalchevanidze/hwm#readme -bug-reports: https://github.com/nalchevanidze/hwm/issues -synopsis: - Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS +cabal-version: 1.12 -description: - HWM (Haskell Workspace Manager) manages multi-package Haskell projects by - generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS - from a single source of truth (hwm.yaml). It handles dependency management, - build matrices across GHC versions, and coordinated package releases. +-- This file has been generated from package.yaml by hpack version 0.36.1. +-- +-- see: https://github.com/sol/hpack -category: Development -build-type: Simple +name: hwm +version: 0.3.0 +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 + from a single source of truth (hwm.yaml). It handles dependency management, + build matrices across GHC versions, and coordinated package releases. +category: Development +homepage: https://github.com/nalchevanidze/hwm#readme +bug-reports: https://github.com/nalchevanidze/hwm/issues +author: Daviti Nalchevanidze +maintainer: d.nalchevanidze@gmail.com +copyright: (c) 2026 Daviti Nalchevanidze +license: MIT +license-file: LICENSE +build-type: Simple extra-source-files: README.md CHANGELOG.md source-repository head - type: git - location: https://github.com/nalchevanidze/hwm + type: git + location: https://github.com/nalchevanidze/hwm library - exposed-modules: - HWM.CLI.App - HWM.CLI.Command - 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.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 - HWM.CLI.Command.Run - HWM.CLI.Command.Status - HWM.CLI.Command.Sync - HWM.CLI.Command.Version - HWM.CLI.Command.Workspace.Add - HWM.CLI.Command.Workspace.Ls - HWM.CLI.Command.Workspace.Root - HWM.Core.Common - HWM.Core.Formatting - HWM.Core.Has - HWM.Core.Options - HWM.Core.Parsing - HWM.Core.Pkg - HWM.Core.Result - HWM.Core.Version - HWM.Domain.Bounds - HWM.Domain.Config - HWM.Domain.ConfigT - HWM.Domain.Dependencies - HWM.Domain.Environments - HWM.Domain.Registry - HWM.Domain.Release - HWM.Domain.Workspace - HWM.Integrations.Scaffold - HWM.Integrations.Toolchain.Cabal - HWM.Integrations.Toolchain.Github - HWM.Integrations.Toolchain.Hie - HWM.Integrations.Toolchain.Hpack - HWM.Integrations.Toolchain.Nix - HWM.Integrations.Toolchain.Package - HWM.Integrations.Toolchain.Stack - HWM.Runtime.Archive - HWM.Runtime.Cache - HWM.Runtime.Files - HWM.Runtime.Logging - HWM.Runtime.Network - HWM.Runtime.Platform - HWM.Runtime.Process - HWM.Runtime.Snapshots - HWM.Runtime.UI - - hs-source-dirs: src - other-modules: Paths_hwm - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - Cabal >=3.8 && <=3.16.1.0, - Glob >=0.10.1 && <=0.10.2, - aeson >=1.5.6.0 && <=2.2.3.0, - ansi-terminal >=0.11.3 && <=1.1.5, - async >2.2.3 && <=2.2.6, - base >=4.7.0 && <5.0.0, - base16-bytestring >=1.0.1.0 && <=1.0.2.0, - bytestring >=0.10.4 && <=0.12.2.0, - containers >=0.4.2.1 && <=0.8, - cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, - directory >=1.0 && <=1.3.10.1, - filepath >=1.1.0 && <=1.5.5.0, - hpack >0.34.4 && <=0.39.1, - modern-uri >=0.3.4.1 && <=0.3.6.1, - mtl >2.0.0 && <2.6.0, - optparse-applicative >=0.16.1.0 && <=0.19.0.0, - process >=1.0.0 && <2.0.0, - relude >=0.7.0.0 && <=1.2.2.2, - req >=3.9.0 && <=3.13.4, - stm >=2.4 && <2.6.0, - text >=1.2.3 && <3.0.0, - time >=1.9.2 && <2.0.0, - transformers >=0.5.6 && <0.7.0, - typed-process >=0.2.6.1 && <=0.2.13.0, - unordered-containers >=0.2.14.0 && <=0.2.21, - yaml >=0.11.5.0 && <=0.11.11.2, - zip-archive >=0.4.1 && <=0.4.3.2 + exposed-modules: + HWM.CLI.App + HWM.CLI.Command + 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.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 + HWM.CLI.Command.Run + HWM.CLI.Command.Status + HWM.CLI.Command.Sync + HWM.CLI.Command.Version + HWM.CLI.Command.Workspace.Add + HWM.CLI.Command.Workspace.Ls + HWM.CLI.Command.Workspace.Root + HWM.Core.Common + HWM.Core.Formatting + HWM.Core.Has + HWM.Core.Options + HWM.Core.Parsing + HWM.Core.Pkg + HWM.Core.Result + HWM.Core.Version + HWM.Domain.Bounds + HWM.Domain.Build + HWM.Domain.Config + HWM.Domain.ConfigT + HWM.Domain.Dependencies + HWM.Domain.Environments + HWM.Domain.Registry + HWM.Domain.Release + HWM.Domain.Workspace + HWM.Integrations.Scaffold + HWM.Integrations.Toolchain.Cabal + HWM.Integrations.Toolchain.Github + HWM.Integrations.Toolchain.Hie + HWM.Integrations.Toolchain.Hpack + HWM.Integrations.Toolchain.Nix + HWM.Integrations.Toolchain.Package + HWM.Integrations.Toolchain.Stack + HWM.Runtime.Archive + HWM.Runtime.Cache + HWM.Runtime.Files + HWM.Runtime.Logging + HWM.Runtime.Network + HWM.Runtime.Platform + HWM.Runtime.Process + HWM.Runtime.Snapshots + HWM.Runtime.UI + other-modules: + Paths_hwm + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + Cabal >=3.8 && <=3.16.1.0 + , Glob >=0.10.2 && <=0.10.2 + , aeson >=1.5.6.0 && <=2.2.3.0 + , ansi-terminal >=0.11.1 && <=1.1.5 + , async >=2.2.4 && <=2.2.6 + , base >=4.7.0 && <5.0.0 + , base16-bytestring >=1.0.2.0 && <=1.0.2.0 + , bytestring >=0.10.4 && <=0.12.2.0 + , containers >=0.4.2.1 && <=0.8 + , cryptohash-sha256 >=0.11.102.1 && <=0.11.102.1 + , directory >=1.0 && <=1.3.10.1 + , filepath >=1.1.0 && <=1.5.5.0 + , hpack >=0.34.6 && <=0.39.3 + , http-client >=0.6.4.1 && <=0.7.19 + , http-types >=0.12.3.0 && <=0.12.4 + , modern-uri >=0.3.4.3 && <=0.3.6.1 + , mtl >2.0.0 && <2.6.0 + , optparse-applicative >=0.16.1.0 && <=0.19.0.0 + , process >=1.0.0 && <2.0.0 + , relude >=0.7.0.0 && <=1.2.2.2 + , req >=3.9.0 && <=3.13.4 + , retry >=0.8.1 && <=0.9.3.1 + , stm >=2.4 && <2.6.0 + , text >=1.2.3 && <3.0.0 + , time >=1.9.2 && <2.0.0 + , transformers >=0.5.6 && <0.7.0 + , typed-process >=0.2.8.0 && <=0.2.13.0 + , unordered-containers >=0.2.16.0 && <=0.2.21 + , yaml >=0.11.8.0 && <=0.11.11.2 + , zip-archive >=0.4.2.1 && <=0.4.3.2 + default-language: Haskell2010 executable hwm - main-is: Main.hs - hs-source-dirs: app - other-modules: Paths_hwm - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - Cabal >=3.8 && <=3.16.1.0, - Glob >=0.10.1 && <=0.10.2, - aeson >=1.5.6.0 && <=2.2.3.0, - ansi-terminal >=0.11.3 && <=1.1.5, - async >2.2.3 && <=2.2.6, - base >=4.7.0 && <5.0.0, - base16-bytestring >=1.0.1.0 && <=1.0.2.0, - bytestring >=0.10.4 && <=0.12.2.0, - containers >=0.4.2.1 && <=0.8, - cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, - directory >=1.0 && <=1.3.10.1, - filepath >=1.1.0 && <=1.5.5.0, - hpack >0.34.4 && <=0.39.1, - hwm >=0.2.0 && <0.3.0, - modern-uri >=0.3.4.1 && <=0.3.6.1, - mtl >2.0.0 && <2.6.0, - optparse-applicative >=0.16.1.0 && <=0.19.0.0, - process >=1.0.0 && <2.0.0, - relude >=0.7.0.0 && <=1.2.2.2, - req >=3.9.0 && <=3.13.4, - stm >=2.4 && <2.6.0, - text >=1.2.3 && <3.0.0, - time >=1.9.2 && <2.0.0, - transformers >=0.5.6 && <0.7.0, - typed-process >=0.2.6.1 && <=0.2.13.0, - unordered-containers >=0.2.14.0 && <=0.2.21, - yaml >=0.11.5.0 && <=0.11.11.2, - zip-archive >=0.4.1 && <=0.4.3.2 - -test-suite hwm-golden-sync - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - other-modules: - Commands.Init - Commands.Sync - Utils.Core - Utils.Golden - Paths_hwm - - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - Cabal >=3.8 && <=3.16.1.0, - Glob >=0.10.1 && <=0.10.2, - aeson >=1.5.6.0 && <=2.2.3.0, - ansi-terminal >=0.11.3 && <=1.1.5, - async >2.2.3 && <=2.2.6, - base >=4.7.0 && <5.0.0, - base16-bytestring >=1.0.1.0 && <=1.0.2.0, - bytestring >=0.10.4 && <=0.12.2.0, - containers >=0.4.2.1 && <=0.8, - cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, - directory >=1.0 && <=1.3.10.1, - filepath >=1.1.0 && <=1.5.5.0, - hpack >0.34.4 && <=0.39.1, - hspec >=0.0 && >=0.0, - modern-uri >=0.3.4.1 && <=0.3.6.1, - mtl >2.0.0 && <2.6.0, - optparse-applicative >=0.16.1.0 && <=0.19.0.0, - process >=1.0.0 && <2.0.0, - relude >=0.7.0.0 && <=1.2.2.2, - req >=3.9.0 && <=3.13.4, - stm >=2.4 && <2.6.0, - temporary >=0.0 && >=0.0, - text >=1.2.3 && <3.0.0, - time >=1.9.2 && <2.0.0, - transformers >=0.5.6 && <0.7.0, - typed-process >=0.2.6.1 && <=0.2.13.0, - unordered-containers >=0.2.14.0 && <=0.2.21, - yaml >=0.11.5.0 && <=0.11.11.2, - zip-archive >=0.4.1 && <=0.4.3.2 + main-is: Main.hs + other-modules: + Paths_hwm + hs-source-dirs: + app + ghc-options: -Wall + build-depends: + Cabal >=3.8 && <=3.16.1.0 + , Glob >=0.10.2 && <=0.10.2 + , aeson >=1.5.6.0 && <=2.2.3.0 + , ansi-terminal >=0.11.1 && <=1.1.5 + , async >=2.2.4 && <=2.2.6 + , base >=4.7.0 && <5.0.0 + , base16-bytestring >=1.0.2.0 && <=1.0.2.0 + , bytestring >=0.10.4 && <=0.12.2.0 + , containers >=0.4.2.1 && <=0.8 + , cryptohash-sha256 >=0.11.102.1 && <=0.11.102.1 + , directory >=1.0 && <=1.3.10.1 + , filepath >=1.1.0 && <=1.5.5.0 + , hpack >=0.34.6 && <=0.39.3 + , http-client >=0.6.4.1 && <=0.7.19 + , http-types >=0.12.3.0 && <=0.12.4 + , hwm >=0.3.0 && <0.4.0 + , modern-uri >=0.3.4.3 && <=0.3.6.1 + , mtl >2.0.0 && <2.6.0 + , optparse-applicative >=0.16.1.0 && <=0.19.0.0 + , process >=1.0.0 && <2.0.0 + , relude >=0.7.0.0 && <=1.2.2.2 + , req >=3.9.0 && <=3.13.4 + , retry >=0.8.1 && <=0.9.3.1 + , stm >=2.4 && <2.6.0 + , text >=1.2.3 && <3.0.0 + , time >=1.9.2 && <2.0.0 + , transformers >=0.5.6 && <0.7.0 + , typed-process >=0.2.8.0 && <=0.2.13.0 + , unordered-containers >=0.2.16.0 && <=0.2.21 + , yaml >=0.11.8.0 && <=0.11.11.2 + , zip-archive >=0.4.2.1 && <=0.4.3.2 + default-language: Haskell2010 diff --git a/src/HWM/CLI/Command/Registry/Add.hs b/src/HWM/CLI/Command/Registry/Add.hs --- a/src/HWM/CLI/Command/Registry/Add.hs +++ b/src/HWM/CLI/Command/Registry/Add.hs @@ -16,7 +16,7 @@ import HWM.Domain.Registry (addDependency, lookupBounds) import HWM.Domain.Workspace (forWorkspaceTuple, resolveWorkspaces) import HWM.Integrations.Toolchain.Package -import HWM.Runtime.UI (putLine, section, sectionConfig, sectionTableM) +import HWM.Runtime.UI (putLine, section, sectionTableM) import Options.Applicative (argument, help, long, metavar, short, str) import Relude @@ -46,9 +46,7 @@ bounds <- deriveBounds opsPkgName range let dependency = Dependency opsPkgName bounds - ((\cf -> pure cf {cfgRegistry = Just $ addDependency dependency (fromMaybe mempty (cfgRegistry cf))}) `updateConfig`) $ do - sectionConfig [("hwm.yaml", pure $ chalk Green "✓")] - addDepToPackage workspaces dependency + ((\cf -> pure cf {cfgRegistry = Just $ addDependency dependency (fromMaybe mempty (cfgRegistry cf))}) `updateConfig`) $ addDepToPackage workspaces dependency Just bounds -> do section "discovery" $ do putLine $ padDots 16 "registry" <> format bounds <> " (already registered)" diff --git a/src/HWM/CLI/Command/Registry/Audit.hs b/src/HWM/CLI/Command/Registry/Audit.hs --- a/src/HWM/CLI/Command/Registry/Audit.hs +++ b/src/HWM/CLI/Command/Registry/Audit.hs @@ -13,7 +13,7 @@ import HWM.Domain.Environments (getTestedRange) import HWM.Domain.Registry (askRegistry, mapDeps, mapWithName) import HWM.Integrations.Toolchain.Package (syncPackages) -import HWM.Runtime.UI (indent, printGenTable, putLine, section, sectionConfig, sectionTableM) +import HWM.Runtime.UI (indent, printGenTable, putLine, section, sectionTableM) import Options.Applicative import Relude @@ -41,7 +41,6 @@ else do if auditFix then ((\cf -> pure $ cf {cfgRegistry = Just $ mapDeps (updateDepBounds auditForce range) originalRegistry}) `updateConfig`) $ do - sectionConfig [("hwm.yaml", pure $ chalk Green "✓")] syncPackages else do injectIssue diff --git a/src/HWM/CLI/Command/Release/Artifacts.hs b/src/HWM/CLI/Command/Release/Artifacts.hs --- a/src/HWM/CLI/Command/Release/Artifacts.hs +++ b/src/HWM/CLI/Command/Release/Artifacts.hs @@ -1,10 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant $" #-} - module HWM.CLI.Command.Release.Artifacts ( ReleaseArchiveOptions (..), parseCLI, @@ -20,12 +17,13 @@ import HWM.Core.Parsing (Parse (..), ParseCLI (..), parseLS) import HWM.Core.Pkg (Pkg (..)) import HWM.Core.Result (fromEither) +import HWM.Domain.Build (Builder (..), buildBinary) import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, Env (..), getArchiveConfigs) +import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) 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 (getGHUploadUrl, uploadToGitHub) import HWM.Runtime.UI (forTable, indent, putLine, section, sectionTableM) @@ -41,7 +39,8 @@ outputDir :: FilePath, ovFormat :: Maybe [Text], ovGhcOptions :: Maybe [Text], - ovNameTemplate :: Maybe Text + ovNameTemplate :: Maybe Text, + opsBuilder :: Maybe Builder } deriving (Show) @@ -60,6 +59,7 @@ <*> optional (option (parseLS <$> str) (long "format" <> metavar "FORMAT" <> help "Override the archive format for the release target. Supported: zip, tar.gz.")) <*> 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.")) + <*> optional (option (str >>= parse) (long "builder" <> metavar "BUILDER" <> help "Override the builder for the release target. Supported: cabal, stack, nix.")) genBindaryDir :: (MonadIO m, ToString a) => a -> m FilePath genBindaryDir name = do @@ -102,14 +102,17 @@ cfgs <- getArchiveConfigs >>= withOverrides ops ghTag <- if ghPublish then Just <$> ensureIsLatestTag version else pure Nothing uploadUrl <- maybe (pure Nothing) (fmap Just . getGHUploadUrl cfg) ghTag - - 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)) - ] + defaultBuilder <- buildBuilder <$> getBuildEnvironment Nothing + let builder = fromMaybe defaultBuilder opsBuilder + 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)), + ("builder", pure $ format builder) + ] - plans <- forTable "build" cfgs (\x -> (fst x, buildPkg x)) + plans <- forTable "build" cfgs (\x -> (fst x, buildPkg outputDir builder x)) section "archive" $ pure () artifacts <- for plans $ \(name, plan) -> do @@ -129,11 +132,12 @@ putLine $ subPathSign <> format archivePath uploadToGitHub url sha256Path putLine $ subPathSign <> format sha256Path - where - buildPkg (name, ArtifactConfig {..}) = do - binaryDir <- genBindaryDir name - let (workspaceId, executableName) = second (T.drop 1) (T.breakOn ":" arcSource) - optTarget <- listToMaybe . concatMap snd <$> resolveWorkspaces [workspaceId] - Pkg {..} <- maybe (throwError $ fromString $ toString $ "Package \"" <> workspaceId <> "\" not found in any workspace. Check package name and workspace configuration.") pure optTarget - stackGenBinary pkgName binaryDir (ghcOptions arcGhcOptions) - pure $ (statusIcon Checked, ArchivingPlan {nameTemplate = arcNameTemplate, outDir = outputDir, sourceDir = binaryDir, name = executableName, archiveFormats = arcFormats}) + +buildPkg :: FilePath -> Builder -> (Name, ArtifactConfig) -> ConfigT (Text, ArchivingPlan) +buildPkg outputDir builder (name, ArtifactConfig {..}) = do + binaryDir <- genBindaryDir name + let (workspaceId, executableName) = second (T.drop 1) (T.breakOn ":" arcSource) + optTarget <- listToMaybe . concatMap snd <$> resolveWorkspaces [workspaceId] + Pkg {..} <- maybe (throwError $ fromString $ toString $ "Package \"" <> workspaceId <> "\" not found in any workspace. Check package name and workspace configuration.") pure optTarget + buildBinary builder pkgName binaryDir (ghcOptions arcGhcOptions) + pure (statusIcon Checked, ArchivingPlan {nameTemplate = arcNameTemplate, outDir = outputDir, sourceDir = binaryDir, name = executableName, archiveFormats = arcFormats}) diff --git a/src/HWM/CLI/Command/Release/Publish.hs b/src/HWM/CLI/Command/Release/Publish.hs --- a/src/HWM/CLI/Command/Release/Publish.hs +++ b/src/HWM/CLI/Command/Release/Publish.hs @@ -16,6 +16,7 @@ import HWM.Core.Formatting ( Color (..), Format (..), + Status (Checked, Invalid), chalk, genMaxLen, padDots, @@ -23,24 +24,33 @@ ) import HWM.Core.Parsing (ParseCLI (..)) import HWM.Core.Pkg (Pkg (..)) -import HWM.Core.Result (Issue, Severity (..), maxSeverity) +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.Integrations.Toolchain.Stack (sdist, upload) +import HWM.Runtime.Network (getHackageToken, uploadToHackage) import HWM.Runtime.UI (printSummary, putLine, section, sectionTableM) import Options.Applicative (argument, help, metavar, str) import Relude hiding (intercalate) +import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) failIssues :: [Issue] -> ConfigT () failIssues [] = pure () -failIssues issues = do - printSummary issues - when (maxSeverity issues == Just SeverityError) $ liftIO exitFailure +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) + newtype PublishOptions = PublishOptions { publishGroup :: Maybe Name } @@ -79,16 +89,24 @@ ] pkgs <- arrangePackageRelease (concatMap snd wgs) - let size = genMaxLen (map printPkgWSRef pkgs) - section "publishing plan (topological sort)" $ do - for_ (zip pkgs [1 ..] :: [(Pkg, Int)]) $ \(pkg, idx) -> do - putLine $ "└── " <> padDots size (printPkgWSRef pkg) <> show idx - issues <- traverse sdist (concatMap snd wgs) - failIssues (concat issues) + 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 + putLine $ "└── " <> padDots size (show idx <> ". " <> printPkgWSRef pkg) <> fromString (makeRelative cwd filePath) + + token <- getHackageToken section "publishing" $ do - for_ pkgs $ \pkg -> do - (status, publishIssues) <- upload pkg + for_ releasePkgs $ \(pkg, filePath) -> do + issues <- uploadToHackage token pkg filePath + let status = if null issues then Checked else Invalid putLine $ "└── " <> padDots size (printPkgWSRef pkg) <> statusIcon status - failIssues publishIssues + failIssues issues diff --git a/src/HWM/CLI/Command/Sync.hs b/src/HWM/CLI/Command/Sync.hs --- a/src/HWM/CLI/Command/Sync.hs +++ b/src/HWM/CLI/Command/Sync.hs @@ -26,9 +26,9 @@ ("resolver", pure $ buildResolver env) ] sectionConfig - ( [("cabal.project", syncCabalProject $> chalk Green "✓")] - <> [("stack.yaml", syncStackYaml $> chalk Green "✓") | buildStack env] - <> [("flake.nix", syncNixFile $> chalk Green "✓") | buildNix env] - <> [("hie.yaml", syncHie $> chalk Green "✓")] + ( [("cabal.project", syncCabalProject)] + <> [("stack.yaml", syncStackYaml) | buildStack env] + <> [("flake.nix", syncNixFile) | buildNix env] + <> [("hie.yaml", syncHie)] ) syncPackages diff --git a/src/HWM/CLI/Command/Version.hs b/src/HWM/CLI/Command/Version.hs --- a/src/HWM/CLI/Command/Version.hs +++ b/src/HWM/CLI/Command/Version.hs @@ -15,7 +15,7 @@ import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, config, updateConfig) import HWM.Integrations.Toolchain.Package (syncPackages) -import HWM.Runtime.UI (putLine, sectionConfig, sectionTableM) +import HWM.Runtime.UI (putLine, sectionTableM) import Options.Applicative (argument, help, metavar) import Options.Applicative.Builder (str) import Relude @@ -54,9 +54,7 @@ pure Config {cfgVersion = version', ..} runVersion :: VersionOptions -> ConfigT () -runVersion (VersionOptions (Just bump)) = (bumpVersion bump `updateConfig`) $ do - sectionConfig [("hwm.yaml", pure $ chalk Green "✓")] - syncPackages +runVersion (VersionOptions (Just bump)) = bumpVersion bump `updateConfig` syncPackages runVersion (VersionOptions Nothing) = do putLine . format . cfgVersion =<< asks config exitSuccess diff --git a/src/HWM/CLI/Command/Workspace/Add.hs b/src/HWM/CLI/Command/Workspace/Add.hs --- a/src/HWM/CLI/Command/Workspace/Add.hs +++ b/src/HWM/CLI/Command/Workspace/Add.hs @@ -6,17 +6,17 @@ import Control.Monad.Error.Class (MonadError (throwError)) import qualified Data.Map as Map -import HWM.Core.Formatting (Color (..), Status (Checked), chalk, displayStatus, padDots, subPathSign) +import HWM.Core.Formatting (Color (..), Status (Checked), chalk, displayStatusM, padDots, subPathSign) import HWM.Core.Parsing (ParseCLI (..)) import HWM.Core.Pkg (PkgName (..), mkPkgDirPath, resolvePrefix) import HWM.Core.Result (Issue (..), MonadIssue (injectIssue), Severity (SeverityError, SeverityWarning)) import HWM.Domain.Config (Config (..)) -import HWM.Domain.ConfigT (ConfigT, Env (config), updateConfig) +import HWM.Domain.ConfigT (ConfigT, Env (config), updateConfig, updateConfigM) import HWM.Domain.Workspace (WorkGroup (..), WorkspaceRef (..), addWorkgroupMember, parseWorkspaceRef) import HWM.Integrations.Scaffold (scaffoldPackage) import HWM.Integrations.Toolchain.Hie (syncHie) import HWM.Integrations.Toolchain.Stack (syncStackYaml) -import HWM.Runtime.UI (putLine, sectionConfig, sectionWorkspace) +import HWM.Runtime.UI (putLine, sectionWorkspace) import Options.Applicative (help, long, metavar, strArgument, strOption) import Relude @@ -47,25 +47,22 @@ } else do let ws = Map.insert groupId (WorkGroup opsWorkspaceDir [] opsPrefix) wss - updateConfig (\cfg -> pure $ cfg {cfgWorkspace = ws}) $ sectionWorkspace $ do + sectionWorkspace $ do putLine "" - displayStatus [("added", pure Checked)] >>= putLine . (("• " <> chalk Bold groupId <> " ") <>) + displayStatusM [("added", pure Checked)] >>= putLine . (("• " <> chalk Bold groupId <> " ") <>) + updateConfig (\cfg -> pure $ cfg {cfgWorkspace = ws}) (pure ()) runWorkspaceAdd (WorkspaceAddOptions {opsWorkspaceId = WorkspaceRef groupId (Just memberId), ..}) = do when (isJust opsPrefix) $ injectIssue (noEffect "prefix") when (isJust opsWorkspaceDir) $ injectIssue (noEffect "dir") (ws, w) <- addWorkgroupMember groupId memberId - scaffoldPackage (mkPkgDirPath (dir w) (prefix w) memberId) (PkgName $ resolvePrefix (prefix w) memberId) - updateConfig (\cfg -> pure $ cfg {cfgWorkspace = ws}) - $ sectionWorkspace + sectionWorkspace $ do putLine "" putLine $ "• " <> chalk Bold groupId - displayStatus [("added", pure Checked)] >>= putLine . ((subPathSign <> padDots 16 memberId) <>) - sectionConfig - [ ("stack.yaml", syncStackYaml $> chalk Green "✓"), - ("hie.yaml", syncHie $> chalk Green "✓") - ] - pure () + xs <- scaffoldPackage (mkPkgDirPath (dir w) (prefix w) memberId) (PkgName $ resolvePrefix (prefix w) memberId) + displayStatusM xs >>= putLine . ((subPathSign <> padDots 16 memberId) <>) + + updateConfigM (\cfg -> pure $ cfg {cfgWorkspace = ws}) [("stack.yaml", syncStackYaml), ("hie.yaml", syncHie)] $ pure () where noEffect label = Issue diff --git a/src/HWM/Core/Formatting.hs b/src/HWM/Core/Formatting.hs --- a/src/HWM/Core/Formatting.hs +++ b/src/HWM/Core/Formatting.hs @@ -1,10 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Eta reduce" #-} - module HWM.Core.Formatting ( Color (..), chalk, @@ -16,8 +13,7 @@ deriveStatus, statusFromSeverity, statusIcon, - isOk, - displayStatus, + displayStatusM, Format (..), availableOptions, renderSummaryStatus, @@ -32,6 +28,7 @@ formatTemplate, toCamelCase, formatTableRow, + StatusM, ) where @@ -42,6 +39,7 @@ import Data.Text (pack) import qualified Data.Text as T import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName) +import HWM.Core.Common (Name) import HWM.Core.Result (MonadIssue (catchIssues), Severity (..)) import Relude @@ -87,9 +85,14 @@ chalk :: Color -> Text -> Text chalk c x = toColor c <> x <> toColor None +type StatusM m = [(Name, m Status)] + data Status = Checked | Updated | Warning | Invalid deriving (Show, Eq, Ord) +instance Semigroup Status where + a <> b = max a b + deriveStatus :: [Status] -> Status deriveStatus [] = Checked deriveStatus statuses = maximum statuses @@ -103,11 +106,11 @@ monadStatus :: (Functor m, MonadIssue m) => m b -> m Status monadStatus x = statusFromSeverity . fst <$> catchIssues x -displayStatus :: (Monad m) => [(Text, m Status)] -> m Text -displayStatus ls = do +displayStatusM :: (Monad m) => StatusM m -> m Text +displayStatusM ls = do statuses <- mapM snd ls let status = deriveStatus statuses - if isOk status then return (statusIcon status) else return (formatStatus (zip (map fst ls) statuses)) + if status == Checked then return (statusIcon status) else return (formatStatus (zip (map fst ls) statuses)) formatTemplate :: [(Text, Text)] -> Text -> Text formatTemplate vars template = @@ -118,11 +121,6 @@ padDots :: Int -> Text -> Text padDots width s = s <> " " <> chalk Dim (T.replicate (max 0 (width - T.length s)) ".") <> " " - -isOk :: Status -> Bool -isOk Checked = True -isOk Updated = True -isOk _ = False labelColor :: Status -> Color labelColor Checked = Dim diff --git a/src/HWM/Core/Pkg.hs b/src/HWM/Core/Pkg.hs --- a/src/HWM/Core/Pkg.hs +++ b/src/HWM/Core/Pkg.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -17,7 +18,8 @@ PkgSource (..), cabalSource, hpackSource, - checkVersion, + getVersionIssues, + PackageIO (..), ) where @@ -35,7 +37,7 @@ import HWM.Core.Formatting import HWM.Core.Has (Has) import HWM.Core.Parsing (Parse (..)) -import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) +import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..)) import HWM.Core.Version (Version, askVersion, fromCabalVersion, toCabalVersion) import HWM.Runtime.Files (cleanRelativePath) import Relude hiding (Undefined, intercalate) @@ -74,6 +76,10 @@ getPkgVersion :: a -> Version setVersion :: Version -> a -> a +class PackageIO a m where + rewritePackage :: (a -> m (Maybe a)) -> Pkg -> m Status + readPackage :: Pkg -> m a + instance IsPkg GenericPackageDescription where getPkgName = PkgName . toText . unPackageName . packageName . package . packageDescription getPkgVersion = fromCabalVersion . pkgVersion . package . packageDescription @@ -138,15 +144,18 @@ instance Parse PkgName where parse = pure . PkgName -checkVersion :: (IsPkg a, MonadReader env m, Has env Version, MonadIssue m) => PkgSource -> a -> m () -checkVersion source pkg = do +getVersionIssues :: (MonadReader env m, Has env Version, IsPkg p) => PkgSource -> p -> m [Issue] +getVersionIssues source pkg = do expectedVersion <- askVersion let version = getPkgVersion pkg - unless (version == expectedVersion) - $ injectIssue - Issue - { issueTopic = pkgSourceName source, - issueMessage = "version mismatch: " <> format version <> " → " <> format expectedVersion, - issueSeverity = SeverityWarning, - issueDetails = Just GenericIssue {issueFile = pkgSourceFile source} - } + if version == expectedVersion + then pure [] + else + pure + [ Issue + { issueTopic = pkgSourceName source, + issueMessage = "version mismatch: " <> format version <> " → " <> format expectedVersion, + issueSeverity = SeverityWarning, + issueDetails = Just GenericIssue {issueFile = pkgSourceFile source} + } + ] diff --git a/src/HWM/Domain/Build.hs b/src/HWM/Domain/Build.hs new file mode 100644 --- /dev/null +++ b/src/HWM/Domain/Build.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module HWM.Domain.Build + ( Builder (..), + buildBinary, + ) +where + +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Except (throwError) +import Data.Aeson (FromJSON (..), ToJSON (toJSON)) +import Data.Aeson.Types (Value (..)) +import HWM.Core.Formatting (Format (..)) +import HWM.Core.Parsing (Parse (..)) +import HWM.Core.Pkg (PkgName) +import HWM.Core.Result (Issue) +import HWM.Runtime.Process (exec) +import Relude +import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, doesPathExist, emptyPermissions, removeFile, setOwnerExecutable, setOwnerReadable, setOwnerWritable, setPermissions) +import System.FilePath (()) + +data Builder + = CabalBuilder + | StackBuilder + | NixBuilder + deriving (Generic, Show, Ord, Eq) + +instance FromJSON Builder where + parseJSON (String s) = parse s + parseJSON _ = fail "Invalid builder. Expected 'cabal', 'stack', or 'nix'." + +instance Parse Builder where + parse "cabal" = pure CabalBuilder + parse "stack" = pure StackBuilder + parse "nix" = pure NixBuilder + parse _ = fail "Invalid builder. Expected 'cabal', 'stack', or 'nix'." + +instance ToJSON Builder where + toJSON = String . format + +instance Format Builder where + format CabalBuilder = "cabal" + format StackBuilder = "stack" + format NixBuilder = "nix" + +buildBinary :: (MonadError Issue m, MonadIO m) => Builder -> PkgName -> FilePath -> [Text] -> m () +buildBinary builder pkgName dirPath args = do + (success, buildOut) <- command + unless success $ throwError (fromString $ "Build failed: " <> buildOut) + when (builder == NixBuilder) (extractNixArtifact pkgName dirPath) + where + command = case builder of + StackBuilder -> + exec "stack" $ ["install", format pkgName, "--local-bin-path", format dirPath] <> args + CabalBuilder -> + exec "cabal" + $ [ "install", + format pkgName, + "--install-method=copy", + "--installdir", + format dirPath, + "--overwrite-policy=always" + ] + <> args + NixBuilder -> + -- WARNING: We DO NOT append 'args' here. + -- Nix does not accept '--ghc-options' via CLI; it must be set in the flake. + exec "nix" ["build", ".#" <> format pkgName, "-o", format (dirPath "result")] + +extractNixArtifact :: (MonadIO m, MonadError Issue m) => PkgName -> FilePath -> m () +extractNixArtifact pkgName distDir = do + let resultLink = distDir "result" + finalDest = distDir toString pkgName + pkgStr = toString (format pkgName) + + liftIO $ createDirectoryIfMissing True distDir + isLink <- liftIO $ doesPathExist resultLink + unless isLink + $ throwError + $ fromString + $ "Nix build completed, but did not create an output at: " + <> resultLink + <> "\n(This usually means the Nix derivation is empty or 'exec' hid a build failure.)" + let searchPaths = + [ resultLink "bin" pkgStr, -- Standard Haskell (Cabal/Stack) + resultLink pkgStr, -- Simple/Single-binary derivation + resultLink -- Derivation is the binary itself + ] + maybeSource <- findM (liftIO . doesFileExist) searchPaths + + case maybeSource of + Just sourcePath -> do + liftIO $ copyFile sourcePath finalDest + -- Ensure the user can execute it (Nix store is read-only) + liftIO $ do + let properPerms = + setOwnerReadable True + $ setOwnerWritable True + $ setOwnerExecutable True emptyPermissions + setPermissions finalDest properPerms + -- Cleanup: Remove the 'result' symlink to keep the folder clean + liftIO $ removeFile resultLink + Nothing -> + throwError + $ fromString + $ "Nix build succeeded, but binary '" + <> pkgStr + <> "' not found inside the Nix store path.\n" + +findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) +findM _ [] = pure Nothing +findM p (x : xs) = do + ifM (p x) (pure $ Just x) (findM p xs) diff --git a/src/HWM/Domain/Config.hs b/src/HWM/Domain/Config.hs --- a/src/HWM/Domain/Config.hs +++ b/src/HWM/Domain/Config.hs @@ -87,6 +87,5 @@ [ ("build", "stack build --fast"), ("test", "stack test {TARGET} --fast"), ("install", "stack install"), - ("lint", "curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s ."), - ("clean", "find . -name \"*.cabal\" -exec rm -rf {} \\; && stack clean") + ("lint", "curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .") ] diff --git a/src/HWM/Domain/ConfigT.hs b/src/HWM/Domain/ConfigT.hs --- a/src/HWM/Domain/ConfigT.hs +++ b/src/HWM/Domain/ConfigT.hs @@ -15,6 +15,7 @@ runConfigT, VersionMap, updateConfig, + updateConfigM, Env (..), unpackConfigT, askCache, @@ -28,7 +29,7 @@ import Control.Monad.Error.Class import HWM.Core.Common (Check (..), Name) -import HWM.Core.Formatting (Format (..)) +import HWM.Core.Formatting (Format (..), Status (..), StatusM) import HWM.Core.Has (Has (..)) import HWM.Core.Options (Options (..)) import HWM.Core.Result (Issue (..), MonadIssue (..), Result (..), ResultT, runResultT) @@ -40,7 +41,7 @@ import HWM.Domain.Workspace (PkgRegistry, Workspace, pkgRegistry) import HWM.Runtime.Cache (Cache, VersionMap, loadCache, saveCache) import HWM.Runtime.Files (Signature, addHash, getFileSignature, readYaml, rewrite_) -import HWM.Runtime.UI (MonadUI (..), UIT, printSummary, runUI) +import HWM.Runtime.UI (MonadUI (..), UIT, printSummary, runUI, sectionConfig) import Relude data Env (m :: Type -> Type) = Env @@ -118,13 +119,18 @@ saveConfig :: (MonadError Issue m, MonadIO m) => Config -> Options -> m () saveConfig config ops = do let file = optionsHwm ops - rewrite_ file (const $ pure config) - addHash file (environmentHash (cfgEnvironments config)) + status <- rewrite_ file (const $ pure config) + case status of + Updated -> addHash file (environmentHash (cfgEnvironments config)) + _ -> pure () updateConfig :: (Config -> ConfigT Config) -> ConfigT b -> ConfigT b -updateConfig f m = do +updateConfig f = updateConfigM f [] + +updateConfigM :: (Config -> ConfigT Config) -> StatusM ConfigT -> ConfigT b -> ConfigT b +updateConfigM f xs m = do config' <- asks config >>= f - local (\e -> e {config = config'}) (checkConfig >> m) + local (\e -> e {config = config'}) (checkConfig >> sectionConfig (("hwm.yaml", pure Updated) : xs) >> m) runConfigT :: ConfigT () -> Options -> IO () runConfigT m opts@Options {..} = do diff --git a/src/HWM/Domain/Dependencies.hs b/src/HWM/Domain/Dependencies.hs --- a/src/HWM/Domain/Dependencies.hs +++ b/src/HWM/Domain/Dependencies.hs @@ -19,10 +19,11 @@ collectNormalizedDependencies, buildDependencyGraph, MapDeps (..), - DependencyIssue, + DependencyBoundsIssue (..), reportDependencyIssues, detectDependencyIssue, mkCabalDependency, + collectDependencyIssues, ) where @@ -30,7 +31,9 @@ import Data.Aeson ( FromJSON (..), ToJSON (..), + Value (..), ) +import Data.Foldable (maximum) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T @@ -43,7 +46,7 @@ import Distribution.Version (LowerBound (..), VersionInterval (..)) import qualified Distribution.Version as Cabal import HWM.Core.Common (Name) -import HWM.Core.Formatting (Format (..), formatTable, subPathSign) +import HWM.Core.Formatting (Format (..), formatTableRow, subPathSign) import HWM.Core.Parsing (Parse (..), firstWord) import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (..), PkgSource (..)) import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) @@ -83,10 +86,17 @@ toDependencyList (Dependencies m) = map (uncurry Dependency) $ Map.toList m instance FromJSON Dependencies where - parseJSON v = initDependencies <$> (parseJSON v >>= traverse parse . sort) + parseJSON (Array v) = initDependencies <$> (parseJSON (Array v) >>= traverse parse . sort) + parseJSON v = Dependencies <$> parseJSON v instance ToJSON Dependencies where - toJSON = toJSON . formatTable . map format . toDependencyList + toJSON (Dependencies ms) = toJSON . Map.mapWithKey formatTable $ ms + where + formatTable key value = + let padding = T.replicate (size - T.length (format key)) " " + in String (padding <> formatTableRow table (T.words (format value))) + size = maximum $ map (T.length . format) $ Map.keys ms + table = map (T.words . format) $ Map.elems ms fromDependencyList :: [Dependency] -> Dependencies fromDependencyList = initDependencies @@ -352,9 +362,20 @@ toRange (Bound Min inc version) = if inc then Cabal.orLaterVersion (toCabalVersion version) else Cabal.laterVersion (toCabalVersion version) toRange (Bound Max inc version) = if inc then Cabal.orEarlierVersion (toCabalVersion version) else Cabal.earlierVersion (toCabalVersion version) -type DependencyIssue = (Text, PkgName, Bounds, Maybe Bounds) +data DependencyBoundsIssue = DependencyBoundsIssue + { depIssueScope :: Text, + depIssueName :: PkgName, + depIssueActual :: Bounds, + depIssueRegistryBounds :: Maybe Bounds + } -reportDependencyIssues :: (MonadIssue m, Applicative m) => PkgSource -> [DependencyIssue] -> m () +collectDependencyIssues :: (Monad m, HasDependencies a) => (PkgName -> m (Maybe Bounds)) -> a -> m [DependencyBoundsIssue] +collectDependencyIssues f pkg = concat <$> traverse checkForDependencyIssues (Map.toList (Map.fromList (collectDependencies [] pkg))) + where + checkForDependencyIssues (path, deps) = concat <$> traverse (getIssue path) (toDependencyList deps) + getIssue path dep = detectDependencyIssue path dep <$> f (hwmDepName dep) + +reportDependencyIssues :: (MonadIssue m, Applicative m) => PkgSource -> [DependencyBoundsIssue] -> m () reportDependencyIssues source diffs = do unless (null diffs) $ injectIssue @@ -365,15 +386,15 @@ issueDetails = Just DependencyIssue - { issueDependencies = map (\(scope, dName, actual, expected) -> (scope, format dName, format actual, maybe "unknown" format expected)) diffs, + { issueDependencies = map (\(DependencyBoundsIssue scope dName actual expected) -> (scope, format dName, format actual, maybe "unknown" format expected)) diffs, issueFile = pkgSourceFile source } } -detectDependencyIssue :: [Text] -> Dependency -> Maybe Bounds -> [DependencyIssue] +detectDependencyIssue :: [Text] -> Dependency -> Maybe Bounds -> [DependencyBoundsIssue] detectDependencyIssue path (Dependency dname depBounds) registryBounds = case registryBounds of - Nothing -> [(scope, dname, depBounds, Nothing)] - Just expected -> ([(scope, dname, depBounds, Just expected) | depBounds /= expected]) + Nothing -> [DependencyBoundsIssue scope dname depBounds Nothing] + Just expected -> [DependencyBoundsIssue scope dname depBounds (Just expected) | depBounds /= expected] where scope = T.intercalate ":" path diff --git a/src/HWM/Domain/Environments.hs b/src/HWM/Domain/Environments.hs --- a/src/HWM/Domain/Environments.hs +++ b/src/HWM/Domain/Environments.hs @@ -46,6 +46,7 @@ import HWM.Core.Result (Issue) import HWM.Core.Version (Era (..), Version, selectEra) import HWM.Domain.Bounds (TestedRange (..)) +import HWM.Domain.Build (Builder (..)) import HWM.Domain.Workspace (Workspace, WorkspaceRef, allPackages, checkWorkspaceRefs, isMember) import HWM.Runtime.Cache (Cache, Registry (currentEnv), VersionMap, getLatestNightlySnapshot, getRegistry, getSnapshot, getVersions) import HWM.Runtime.Files (Signature, aesonYAMLOptions, aesonYAMLOptionsAdvanced, genSignature) @@ -55,7 +56,8 @@ type Extras = VersionMap data Environments = Environments - { envDefault :: Name, + { envBuilder :: Maybe Builder, + envDefault :: Name, envNix :: Maybe Bool, envStack :: Maybe Bool, envProfiles :: Map Name Enviroment @@ -184,7 +186,8 @@ buildResolver :: Name, buildAllowNewer :: Maybe Bool, buildStack :: Bool, - buildNix :: Bool + buildNix :: Bool, + buildBuilder :: Builder } deriving ( Generic, @@ -218,7 +221,8 @@ buildGHC = ghc env, buildAllowNewer = stack env >>= unfeature >>= allowNewer, buildStack = isEnabled (envStack globalEnv) (stack env), - buildNix = isEnabled (envNix globalEnv) (nix env) + buildNix = isEnabled (envNix globalEnv) (nix env), + buildBuilder = fromMaybe CabalBuilder (envBuilder globalEnv) } where excludePkgs build pkgs = diff --git a/src/HWM/Domain/Workspace.hs b/src/HWM/Domain/Workspace.hs --- a/src/HWM/Domain/Workspace.hs +++ b/src/HWM/Domain/Workspace.hs @@ -18,7 +18,6 @@ forWorkspace, forWorkspaceTuple, parseWorkspaceRef, - forWorkspaceCore, addWorkgroupMember, allPackages, resolveWsPkgs, @@ -46,7 +45,7 @@ import qualified Data.Set as S import qualified Data.Text as T import HWM.Core.Common (Name) -import HWM.Core.Formatting (Color (..), availableOptions, chalk, commonPrefix, genMaxLen, monadStatus, padDots, slugify, statusIcon, subPathSign) +import HWM.Core.Formatting (Color (..), StatusM, availableOptions, chalk, commonPrefix, displayStatusM, genMaxLen, padDots, slugify, subPathSign) import HWM.Core.Has (Has (..), askEnv) import HWM.Core.Pkg (Pkg (..), PkgName (..), makePkg) import HWM.Core.Result @@ -192,13 +191,8 @@ compareMembers _ "." = LT compareMembers x y = compare x y -forWorkspace :: (MonadIO m, MonadUI m, MonadIssue m, MonadError Issue m, MonadReader env m, Has env Workspace) => (Pkg -> m ()) -> m () -forWorkspace f = forWorkspaceCore $ \pkg -> do - status <- monadStatus (f pkg) - pure $ statusIcon status - -forWorkspaceCore :: (MonadIO m, MonadUI m, MonadIssue m, MonadError Issue m, MonadReader env m, Has env Workspace) => (Pkg -> m Text) -> m () -forWorkspaceCore f = do +forWorkspace :: (MonadIO m, MonadUI m, MonadIssue m, MonadError Issue m, MonadReader env m, Has env Workspace) => (Pkg -> StatusM m) -> m () +forWorkspace f = do gs <- Map.toList <$> askWorkspace sectionWorkspace $ for_ gs @@ -208,17 +202,17 @@ pkgs <- memberPkgs (name, wg) let maxLen = genMaxLen (map pkgMemberId pkgs) for_ pkgs $ \pkg -> do - status <- f pkg + status <- displayStatusM (f pkg) putLine $ subPathSign <> padDots maxLen (pkgMemberId pkg) <> status -forWorkspaceTuple :: (MonadUI m) => [(Text, [Pkg])] -> (Pkg -> m Text) -> m () +forWorkspaceTuple :: (MonadUI m) => [(Text, [Pkg])] -> (Pkg -> StatusM m) -> m () forWorkspaceTuple ws f = sectionWorkspace $ do let maxLen = genMaxLen (map pkgMemberId $ concatMap snd ws) for_ ws $ \(name, pkgs) -> do putLine "" putLine $ "• " <> chalk Bold name for_ pkgs $ \pkg -> do - status <- f pkg + status <- displayStatusM (f pkg) putLine (subPathSign <> padDots maxLen (pkgMemberId pkg) <> status) addWorkgroupMember :: (MonadIO m, MonadUI m, MonadIssue m, MonadError Issue m, MonadReader env m, Has env Workspace) => Name -> Name -> m (Workspace, WorkGroup) diff --git a/src/HWM/Integrations/Scaffold.hs b/src/HWM/Integrations/Scaffold.hs --- a/src/HWM/Integrations/Scaffold.hs +++ b/src/HWM/Integrations/Scaffold.hs @@ -4,6 +4,7 @@ module HWM.Integrations.Scaffold (scaffoldPackage) where import qualified Data.Text as T +import HWM.Core.Formatting (Status (..), StatusM) import HWM.Core.Pkg (PkgName) import HWM.Domain.ConfigT (ConfigT) import HWM.Integrations.Toolchain.Package (newPackage) @@ -20,8 +21,14 @@ "someFunc = putStrLn \"Scaffolded by HWM\"" ] -scaffoldPackage :: FilePath -> PkgName -> ConfigT () +writeSource :: FilePath -> ConfigT (StatusM ConfigT) +writeSource targetDir = liftIO $ do + createDirectoryIfMissing True (targetDir "src") + writeFile (targetDir "src/Lib.hs") (T.unpack libHsTemplate) + pure [("src", pure Updated)] + +scaffoldPackage :: FilePath -> PkgName -> ConfigT (StatusM ConfigT) scaffoldPackage targetDir pkgName = do - liftIO $ createDirectoryIfMissing True (targetDir "src") - newPackage targetDir pkgName - liftIO $ writeFile (targetDir "src/Lib.hs") (T.unpack libHsTemplate) + sts <- writeSource targetDir + fs <- map (second pure) <$> newPackage targetDir pkgName + pure $ sts <> fs diff --git a/src/HWM/Integrations/Toolchain/Cabal.hs b/src/HWM/Integrations/Toolchain/Cabal.hs --- a/src/HWM/Integrations/Toolchain/Cabal.hs +++ b/src/HWM/Integrations/Toolchain/Cabal.hs @@ -1,54 +1,66 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Integrations.Toolchain.Cabal - ( rewriteCabalPackage, - validateHackage, + ( validateHackage, syncCabalProject, - readCabalPackage, HasSourceDirs (..), CabalPackage, newCabalPackage, + readCabalPackage, + nativeSdist, ) where +import Control.Exception (IOException) +import Control.Exception.Base (try) import Control.Monad.Except (MonadError (throwError)) import qualified Data.ByteString as BS import Data.Foldable (Foldable (..)) import qualified Data.Map as Map import qualified Data.Text as T -import qualified Data.Text.IO as TIO +import Distribution.Package (packageVersion) import Distribution.PackageDescription (Benchmark (..), Executable (..), GenericPackageDescription (..), PackageDescription (..), PackageIdentifier (..), TestSuite (..), UnqualComponentName, emptyBuildInfo, emptyLibrary, emptyPackageDescription, mkPackageName, packageDescription) import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription) +import Distribution.Simple.Flag (toFlag) import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.Setup (SDistFlags (..), defaultSDistFlags) +import Distribution.Simple.SrcDist (sdist) +import Distribution.Text (display) import Distribution.Types.BuildInfo (BuildInfo (..)) import Distribution.Types.CondTree (CondTree (..)) import Distribution.Types.Library (Library (..)) import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity (normal) +import qualified Distribution.Verbosity as Verbosity import HWM.Core.Common (Name) import HWM.Core.Formatting (Format (..), Status (..)) import HWM.Core.Options (Options (..)) -import HWM.Core.Pkg (IsPkg (..), Pkg (Pkg, hpackFile), PkgName) +import HWM.Core.Pkg (IsPkg (..), PackageIO, Pkg (Pkg, hpackFile), PkgName) import qualified HWM.Core.Pkg as P -import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) +import HWM.Core.Result (Issue (..), MonadIssue (..), Severity (..)) import HWM.Core.Version (Version, toCabalVersion) import HWM.Domain.ConfigT (ConfigT) import qualified HWM.Domain.ConfigT as CT import HWM.Domain.Dependencies (Dependencies (..), HasDependencies (..), MapDeps (..), mkCabalDependency, toDependencyList) import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) -import Hpack (Result (..), defaultOptions, hpackResult, setProgramName, setTarget) +import HWM.Runtime.Files (syncFile) +import Hpack (Force (..), Options (..), Result (..), defaultOptions, hpackResult, setProgramName, setTarget) import qualified Hpack as H import Hpack.Config (ProgramName (..)) import Relude +import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute, removePathForcibly, renameFile, withCurrentDirectory) import System.FilePath (takeDirectory, ()) --- | Translate Cabal warnings into formatting status for downstream reporting. toStatus :: PackageCheck -> Status toStatus p | isError p = Invalid @@ -61,40 +73,64 @@ isError PackageDistSuspiciousWarn {} = False isError PackageDistSuspicious {} = False -validateHackage :: Pkg -> FilePath -> ConfigT [Status] -validateHackage pkg path = do - gpd <- liftIO $ readGenericPackageDescription normal path +toIssue :: Pkg -> PackageCheck -> Issue +toIssue pkg check = + Issue + { issueMessage = "Invalid Package [Cabal check]: " <> show check, + issueSeverity = if isError check then SeverityError else SeverityWarning, + issueTopic = P.pkgMemberId pkg, + issueDetails = Nothing + } + +validateHackage :: Pkg -> ConfigT Status +validateHackage pkg = do + gpd <- liftIO $ readGenericPackageDescription normal (P.cabalFile pkg) let ls = checkPackage gpd Nothing - for_ ls $ \l -> do - injectIssue - ( Issue - { issueMessage = "Invalid package: " <> show l, - issueSeverity = if isError l then SeverityError else SeverityWarning, - issueTopic = P.pkgMemberId pkg, - issueDetails = Just GenericIssue {issueFile = path} - } - ) - pure (map toStatus ls) + for_ ls $ \l -> injectIssue (toIssue pkg l) + pure (maximum (Checked : map toStatus ls)) -hpackSync :: Pkg -> ConfigT Status -hpackSync Pkg {hpackFile = Nothing} = pure Checked -hpackSync pkg@Pkg {hpackFile = Just path} = do +instance PackageIO CabalPackage ConfigT where + rewritePackage = rewriteCabalPackage + readPackage = readCabalPackage + +getChanges :: Pkg -> (CabalPackage -> ConfigT (Maybe CabalPackage)) -> ConfigT (Maybe CabalPackage) +getChanges pkg mapCabal = do + original <- readCabalPackage pkg + updated <- mapCabal original + case updated of + Nothing -> pure Nothing + Just newpackage -> + if cbContent newpackage == cbContent original + then pure Nothing + else pure (Just newpackage) + +forChanges :: (Applicative f) => Maybe t -> (t -> f a) -> f Status +forChanges changes f = do + case changes of + Nothing -> pure Checked + Just newpackage -> f newpackage $> Updated + +rewriteCabalPackage :: (CabalPackage -> ConfigT (Maybe CabalPackage)) -> Pkg -> ConfigT Status +rewriteCabalPackage mapCabal pkg@Pkg {hpackFile = Just path} = do + changes <- getChanges pkg mapCabal + update <- forChanges changes $ \_ -> hpackForceUpdate pkg path + validation <- validateHackage pkg + pure $ max validation update +rewriteCabalPackage mapCabal pkg = do + changes <- getChanges pkg mapCabal + update <- forChanges changes $ \package -> liftIO $ writeGenericPackageDescription (P.cabalFile pkg) (cbContent package) + validation <- validateHackage pkg + pure $ max validation update + +hpackForceUpdate :: (MonadIO m) => Pkg -> FilePath -> m Status +hpackForceUpdate pkg path = do let programName = ProgramName $ toString $ P.pkgName pkg - let ops = setTarget path $ setProgramName programName defaultOptions + let ops = setTarget path $ setProgramName programName defaultOptions {optionsForce = Force} Result {..} <- liftIO $ hpackResult ops case resultStatus of H.OutputUnchanged -> pure Checked _ -> pure Updated -rewriteCabalPackage :: (CabalPackage -> ConfigT CabalPackage) -> Pkg -> ConfigT Status -rewriteCabalPackage mapCabal pkg = do - s <- hpackSync pkg - ls <- validateHackage pkg (P.cabalFile pkg) - cabalP <- readCabalPackage pkg - newpackage <- mapCabal cabalP - liftIO $ writeGenericPackageDescription (P.cabalFile pkg) (cbOriginal newpackage) - pure $ maximum (s : ls) - generateCabalProject :: [Pkg] -> Text -> Text generateCabalProject packagePaths ghcVersion = T.unlines @@ -102,15 +138,15 @@ "packages:\n" <> T.unlines (map ((" " <>) . format . P.pkgDirPath) packagePaths) ] -syncCabalProject :: ConfigT () +syncCabalProject :: ConfigT Status syncCabalProject = do - ops <- asks CT.options + cabalFilePath <- asks (optionsCabal . CT.options) BuildEnvironment {..} <- getBuildEnvironment Nothing - liftIO $ TIO.writeFile (optionsCabal ops) (generateCabalProject buildPkgs (toText buildGHC)) + syncFile cabalFilePath (generateCabalProject buildPkgs (toText buildGHC)) data CabalPackage = CabalPackage { cbDirectory :: FilePath, - cbOriginal :: GenericPackageDescription + cbContent :: GenericPackageDescription } deriving (Show) @@ -129,7 +165,7 @@ pure CabalPackage { cbDirectory = takeDirectory (P.cabalFile pkg), - cbOriginal = gpd + cbContent = gpd } class HasSourceDirs a where @@ -143,7 +179,7 @@ getSourceDirs tags libs = concatMap (\(name, lib) -> getSourceDirs (tags <> [name]) lib) (Map.toList libs) instance HasSourceDirs CabalPackage where - getSourceDirs p CabalPackage {..} = getSourceDirs p cbOriginal + getSourceDirs p CabalPackage {..} = getSourceDirs p cbContent instance HasSourceDirs GenericPackageDescription where getSourceDirs p GenericPackageDescription {..} = @@ -176,22 +212,23 @@ withKey dir = (T.intercalate ":" path, format dir) instance IsPkg CabalPackage where - getPkgName = getPkgName . cbOriginal - getPkgVersion = getPkgVersion . cbOriginal - setVersion version pkg = pkg {cbOriginal = setVersion version (cbOriginal pkg)} + getPkgName = getPkgName . cbContent + getPkgVersion = getPkgVersion . cbContent + setVersion version pkg = pkg {cbContent = setVersion version (cbContent pkg)} instance HasDependencies CabalPackage where - collectDependencies xs gpd = collectDependencies xs (cbOriginal gpd) + collectDependencies xs gpd = collectDependencies xs (cbContent gpd) instance MapDeps CabalPackage where mapDeps ctx f cabalPkg = do - newGpd <- mapDeps ctx f (cbOriginal cabalPkg) - pure cabalPkg {cbOriginal = newGpd} + newGpd <- mapDeps ctx f (cbContent cabalPkg) + pure cabalPkg {cbContent = newGpd} -newCabalPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m () +newCabalPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m Status newCabalPackage dir name version deps = do let package = emptyPackage name version deps liftIO $ writeGenericPackageDescription (dir (toString name <> ".cabal")) package + pure Updated emptyPackage :: PkgName -> Version -> Dependencies -> GenericPackageDescription emptyPackage (P.PkgName name) version dependencies = @@ -218,3 +255,41 @@ condSubLibraries = [], condForeignLibs = [] } + +err :: Pkg -> Text -> Issue +err pkg msg = Issue (P.pkgMemberId pkg) SeverityError msg Nothing + +nativeSdist :: Pkg -> ConfigT ((Pkg, Maybe FilePath), [Issue]) +nativeSdist pkg = do + gpkg <- readCabalFile pkg + outDir <- liftIO (makeAbsolute $ "./.hwm/sdist" toString (P.pkgName pkg)) + (filePath, issues) <- runNativeSDist pkg (flattenPackageDescription gpkg) outDir + pure ((pkg, filePath), issues <> map (toIssue pkg) (checkPackage gpkg Nothing)) + +runNativeSDist :: Pkg -> PackageDescription -> FilePath -> ConfigT (Maybe FilePath, [Issue]) +runNativeSDist pkg pkgDesc outDir = do + let tarName = toString (P.pkgName pkg) <> "-" <> display (packageVersion (package pkgDesc)) <> ".tar.gz" + -- We'll look for it here: package_dir/dist/package-version.tar.gz + localDistDir = P.pkgDirPath pkg "dist" + tempTarPath = localDistDir tarName + finalPath = outDir tarName + + result <- liftIO $ try $ do + -- Setup the HWM output dir + removePathForcibly outDir + createDirectoryIfMissing True outDir + -- prepare the 'dist' folder inside the package dir and run sdist + removePathForcibly localDistDir + createDirectoryIfMissing True localDistDir + withCurrentDirectory (P.pkgDirPath pkg) $ sdist pkgDesc (defaultSDistFlags {sDistVerbosity = toFlag Verbosity.silent}) (const "") knownSuffixHandlers + exists <- doesFileExist tempTarPath + if exists + then renameFile tempTarPath finalPath >> pure (Just finalPath) + else pure Nothing + + case result of + Right (Just path) -> pure (Just path, []) + Right Nothing -> + pure (Nothing, [err pkg $ "Cabal sdist ran, but " <> toText tarName <> " was not found."]) + Left (e :: IOException) -> + pure (Nothing, [err pkg $ "Cabal sdist IO Error: " <> show e]) diff --git a/src/HWM/Integrations/Toolchain/Hie.hs b/src/HWM/Integrations/Toolchain/Hie.hs --- a/src/HWM/Integrations/Toolchain/Hie.hs +++ b/src/HWM/Integrations/Toolchain/Hie.hs @@ -15,7 +15,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object) import HWM.Core.Common (Name) -import HWM.Core.Formatting (Format (format)) +import HWM.Core.Formatting (Format (format), Status (..)) import HWM.Core.Options (Options (..), askOptions) import HWM.Core.Pkg (Pkg (..), pkgFile) import HWM.Domain.ConfigT (ConfigT) @@ -54,7 +54,7 @@ where comp (tag, sourceDirs) = Component {path = "./" <> pkgFile pkg (toString sourceDirs), component = tag} -syncHie :: ConfigT () +syncHie :: ConfigT Status syncHie = do Options {..} <- askOptions pkgs <- allPackages diff --git a/src/HWM/Integrations/Toolchain/Hpack.hs b/src/HWM/Integrations/Toolchain/Hpack.hs --- a/src/HWM/Integrations/Toolchain/Hpack.hs +++ b/src/HWM/Integrations/Toolchain/Hpack.hs @@ -1,14 +1,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Integrations.Toolchain.Hpack ( HpackPackage (..), - readHpackPackage, - rewriteHpackPackage, newHpackPackage, + readHpackPackage, ) where @@ -21,11 +21,12 @@ import GHC.Generics (Generic (..)) import HWM.Core.Common (Name) import HWM.Core.Formatting (Status (Checked)) -import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (..)) +import HWM.Core.Pkg (IsPkg (..), PackageIO (..), Pkg (..), PkgName (..)) import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..)) import HWM.Core.Version (Version) +import HWM.Domain.ConfigT (ConfigT) import HWM.Domain.Dependencies (Dependencies, HasDependencies (..), MapDeps (..)) -import HWM.Runtime.Files (aesonYAMLOptions, aesonYAMLOptionsAdvanced, readYaml, rewrite_, statusM) +import HWM.Runtime.Files (aesonYAMLOptions, aesonYAMLOptionsAdvanced, readYaml, rewriteMaybe_, rewrite_, statusM) import Hpack () import Relude import System.FilePath (()) @@ -137,23 +138,9 @@ hpackForeignLibraries = Nothing } -readHpackPackage :: (Monad m, MonadError Issue m, MonadIO m) => Pkg -> m HpackPackage -readHpackPackage pkg = - maybe - ( throwError - $ Issue - { issueTopic = pkgMemberId pkg, - issueMessage = "pkg does not support hpack or could not find package file", - issueSeverity = SeverityWarning, - issueDetails = Just GenericIssue {issueFile = cabalFile pkg} - } - ) - readYaml - (hpackFile pkg) - -rewriteHpackPackage :: (MonadIO m, MonadError Issue m) => (HpackPackage -> m HpackPackage) -> Pkg -> m Status +rewriteHpackPackage :: (MonadIO m, MonadError Issue m) => (HpackPackage -> m (Maybe HpackPackage)) -> Pkg -> m Status rewriteHpackPackage f pkg = do - maybe (pure Checked) (\path -> statusM path (rewrite_ path maybePackage)) (hpackFile pkg) + maybe (pure Checked) (\path -> statusM path (rewriteMaybe_ path maybePackage)) (hpackFile pkg) where maybePackage Nothing = throwError @@ -165,7 +152,25 @@ } maybePackage (Just package) = f package -newHpackPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m () +newHpackPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m Status newHpackPackage dir name version deps = do let package = emptyPackage name version deps rewrite_ (dir "package.yaml") (const $ pure package) + +instance PackageIO HpackPackage ConfigT where + rewritePackage = rewriteHpackPackage + readPackage = readHpackPackage + +readHpackPackage :: (MonadError Issue m, MonadIO m) => Pkg -> m HpackPackage +readHpackPackage pkg = + maybe + ( throwError + $ Issue + { issueTopic = pkgMemberId pkg, + issueMessage = "pkg does not support hpack or could not find package file", + issueSeverity = SeverityWarning, + issueDetails = Just GenericIssue {issueFile = cabalFile pkg} + } + ) + readYaml + (hpackFile pkg) diff --git a/src/HWM/Integrations/Toolchain/Nix.hs b/src/HWM/Integrations/Toolchain/Nix.hs --- a/src/HWM/Integrations/Toolchain/Nix.hs +++ b/src/HWM/Integrations/Toolchain/Nix.hs @@ -6,23 +6,23 @@ module HWM.Integrations.Toolchain.Nix (syncNixFile) where import qualified Data.Text as T -import qualified Data.Text.IO as TIO import HWM.Core.Common (Name) -import HWM.Core.Formatting (format, toCamelCase) +import HWM.Core.Formatting (Status, format, toCamelCase) import HWM.Core.Options (Options (..)) import HWM.Core.Pkg (Pkg (..)) import HWM.Core.Version (Era (eraNixpkgs), Version, formatNixGhc, selectEra) import HWM.Domain.Config (Config (Config, cfgName)) import HWM.Domain.ConfigT (ConfigT, Env (..)) import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) +import HWM.Runtime.Files (syncFile) import Relude -syncNixFile :: ConfigT () +syncNixFile :: ConfigT Status syncNixFile = do Config {..} <- asks config ops <- asks options BuildEnvironment {buildPkgs, buildGHC} <- getBuildEnvironment Nothing - liftIO $ TIO.writeFile (optionsNix ops) (deriveFlakeNix cfgName buildGHC buildPkgs) + syncFile (optionsNix ops) (deriveFlakeNix cfgName buildGHC buildPkgs) renderNixName :: Text -> Text renderNixName name = toCamelCase name <> "WorkspacePackages" diff --git a/src/HWM/Integrations/Toolchain/Package.hs b/src/HWM/Integrations/Toolchain/Package.hs --- a/src/HWM/Integrations/Toolchain/Package.hs +++ b/src/HWM/Integrations/Toolchain/Package.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Integrations.Toolchain.Package @@ -16,46 +15,54 @@ where import qualified Data.Text as T -import HWM.Core.Formatting (displayStatus) -import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (PkgName), PkgSource (..), cabalSource, checkVersion, hpackSource) +import HWM.Core.Formatting (Status, StatusM, monadStatus) +import HWM.Core.Pkg (IsPkg (..), PackageIO (..), Pkg (..), PkgName (PkgName), PkgSource (..), cabalSource, getVersionIssues, hpackSource) +import HWM.Core.Result (Issue, MonadIssue (injectIssue)) import HWM.Domain.Bounds (Bounds (Bounds)) import HWM.Domain.Config (getRegistryBounds) import HWM.Domain.ConfigT (ConfigT, askVersion) import HWM.Domain.Dependencies ( Dependencies, Dependency (..), + DependencyBoundsIssue (..), DependencyMap (..), HasDependencies (..), MapDeps (..), buildDependencyGraph, - detectDependencyIssue, + collectDependencyIssues, fromDependencyList, reportDependencyIssues, singleDeps, toDependencyList, ) import qualified HWM.Domain.Dependencies as M -import HWM.Domain.Workspace (allPackages, forWorkspace, forWorkspaceCore) -import HWM.Integrations.Toolchain.Cabal (CabalPackage, newCabalPackage, readCabalPackage, rewriteCabalPackage) -import HWM.Integrations.Toolchain.Hpack (HpackPackage, newHpackPackage, readHpackPackage, rewriteHpackPackage) +import HWM.Domain.Workspace (allPackages, forWorkspace) +import HWM.Integrations.Toolchain.Cabal (CabalPackage, newCabalPackage, readCabalPackage, validateHackage) +import HWM.Integrations.Toolchain.Hpack (HpackPackage, newHpackPackage, readHpackPackage) import Relude -newPackage :: FilePath -> PkgName -> ConfigT () +newPackage :: FilePath -> PkgName -> ConfigT [(Text, Status)] newPackage targetDir name = do let baseName = PkgName "base" version <- askVersion base <- fromMaybe (Bounds Nothing Nothing) <$> getRegistryBounds baseName let deps = M.singleDeps (Dependency baseName base) - newHpackPackage targetDir name version deps - newCabalPackage targetDir name version deps + hpack <- newHpackPackage targetDir name version deps + cabal <- newCabalPackage targetDir name version deps + pure [("hpack", hpack), ("cabal", cabal)] syncPackages :: ConfigT () -syncPackages = forWorkspaceCore $ updatePackage syncPackage syncPackage +syncPackages = forWorkspace $ updatePackage syncPackage syncPackage -syncPackage :: (MapDeps a, IsPkg a) => PkgSource -> a -> ConfigT a +syncPackage :: (MapDeps a, IsPkg a, HasDependencies a) => PkgSource -> a -> ConfigT (Maybe a) syncPackage pkg package = do - result <- mapDeps (pkg, []) syncDeps package - (`setVersion` result) <$> askVersion + noIssues <- hasNoIssues pkg package + if noIssues + then pure Nothing + else + Just <$> do + result <- mapDeps (pkg, []) syncDeps package + (`setVersion` result) <$> askVersion syncDeps :: (PkgSource, [Text]) -> Dependencies -> ConfigT Dependencies syncDeps (pkg, path) deps = @@ -65,41 +72,53 @@ where syncDep (Dependency depName depBounds) = do bounds <- getRegistryBounds depName - pure ([(T.intercalate ":" path, depName, depBounds, Nothing) | isNothing bounds], Dependency depName (fromMaybe depBounds bounds)) + pure ([DependencyBoundsIssue (T.intercalate ":" path) depName depBounds Nothing | isNothing bounds], Dependency depName (fromMaybe depBounds bounds)) -addDeps :: (MapDeps a) => Dependency -> PkgSource -> a -> ConfigT a -addDeps dependency pkg = mapDeps (pkg, []) onlyMain +addDeps :: (MapDeps a) => Dependency -> PkgSource -> a -> ConfigT (Maybe a) +addDeps dependency pkg = fmap Just . mapDeps (pkg, []) onlyMain where onlyMain (_, ["dependencies"]) deps = pure (deps <> singleDeps dependency) onlyMain _ deps = pure deps -addPkgDependency :: Dependency -> Pkg -> ConfigT Text +addPkgDependency :: Dependency -> Pkg -> StatusM ConfigT addPkgDependency dep = updatePackage (addDeps dep) (addDeps dep) -updatePackage :: (PkgSource -> HpackPackage -> ConfigT HpackPackage) -> (PkgSource -> CabalPackage -> ConfigT CabalPackage) -> Pkg -> ConfigT Text -updatePackage mapHpack mapCabal pkg = - displayStatus - ( map (\s -> ("hpack", rewriteHpackPackage (mapHpack s) pkg)) (maybeToList $ hpackSource pkg) - <> [("cabal", rewriteCabalPackage (mapCabal (cabalSource pkg)) pkg)] - ) +forFormats :: (IsString a) => (PkgSource -> Pkg -> b) -> (PkgSource -> Pkg -> b) -> Pkg -> [(a, b)] +forFormats hpack cabal pkg = + map (\s -> ("hpack", hpack s pkg)) (maybeToList $ hpackSource pkg) + <> [("cabal", cabal (cabalSource pkg) pkg)] +updatePackage :: (PkgSource -> HpackPackage -> ConfigT (Maybe HpackPackage)) -> (PkgSource -> CabalPackage -> ConfigT (Maybe CabalPackage)) -> Pkg -> StatusM ConfigT +updatePackage mapHpack mapCabal = forFormats (rewritePackage . mapHpack) (rewritePackage . mapCabal) + deriveDependencyGraph :: ConfigT DependencyMap deriveDependencyGraph = buildDependencyGraph (concatMap (toDependencyList . snd) . libDependencies) <$> (allPackages >>= traverse readCabalPackage) where libDependencies = filter (\x -> fst x == ["library"]) . collectDependencies [] validatePackages :: ConfigT () -validatePackages = forWorkspace $ \pkg -> do - cabal <- readCabalPackage pkg - hpack <- traverse (\x -> (x,) <$> readHpackPackage pkg) (maybeToList $ hpackSource pkg) - validatePackage (cabalSource pkg, cabal) - for_ hpack validatePackage - -validatePackage :: (IsPkg a, HasDependencies a) => (PkgSource, a) -> ConfigT () -validatePackage (source, package) = do - checkVersion source package - diffs <- concat <$> traverse checkForDependencyIssues (collectDependencies [] package) - reportDependencyIssues source diffs +validatePackages = forWorkspace $ forFormats hpack cabal where - checkForDependencyIssues (path, deps) = concat <$> traverse (getIssue path) (toDependencyList deps) - getIssue path dep = detectDependencyIssue path dep <$> getRegistryBounds (hwmDepName dep) + hpack src pkg = readHpackPackage pkg >>= validatePackage src + cabal _ pkg = do + s1 <- readCabalPackage pkg >>= validatePackage (cabalSource pkg) + s2 <- validateHackage pkg + pure (s1 <> s2) + +hasNoIssues :: (IsPkg a, HasDependencies a) => PkgSource -> a -> ConfigT Bool +hasNoIssues source pkg = do + (issues, depIssues) <- collectIssues source pkg + let depIssues' = filter (isJust . depIssueRegistryBounds) depIssues + pure (null issues && null depIssues') + +collectIssues :: (IsPkg a, HasDependencies a) => PkgSource -> a -> ConfigT ([Issue], [DependencyBoundsIssue]) +collectIssues source pkg = do + versionIssues <- getVersionIssues source pkg + depIssues <- collectDependencyIssues getRegistryBounds pkg + pure (versionIssues, depIssues) + +validatePackage :: (IsPkg a, HasDependencies a) => PkgSource -> a -> ConfigT Status +validatePackage source package = monadStatus $ do + (issues, depIssues) <- collectIssues source package + traverse_ injectIssue issues + reportDependencyIssues source depIssues diff --git a/src/HWM/Integrations/Toolchain/Stack.hs b/src/HWM/Integrations/Toolchain/Stack.hs --- a/src/HWM/Integrations/Toolchain/Stack.hs +++ b/src/HWM/Integrations/Toolchain/Stack.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -12,13 +11,9 @@ syncStackYaml, createEnvYaml, stackPath, - sdist, - upload, parseExtraDeps, scanStackFiles, buildMatrix, - runStack, - stackGenBinary, ) where @@ -30,22 +25,20 @@ genericToJSON, ) import qualified Data.Map as Map -import Data.Text (pack) import qualified Data.Text as T import HWM.Core.Common (Name) -import HWM.Core.Formatting (Format (..), Status (..), indentBlockNum, slugify) +import HWM.Core.Formatting (Format (..), Status (..), slugify) import HWM.Core.Options (Options (..), askOptions) import HWM.Core.Parsing (Parse (..)) import HWM.Core.Pkg (Pkg (..), PkgName) -import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..), fromEither) +import HWM.Core.Result (Issue (..), fromEither) import HWM.Core.Version (Version, latestGHCVersion, parseGHCVersion) +import HWM.Domain.Build (Builder (StackBuilder)) import HWM.Domain.ConfigT (ConfigT) import HWM.Domain.Environments (BuildEnvironment (..), Enviroment (..), Environments (..), Feature (..), StackEnvironment (..), getBuildEnvironment, hkgRefs) import HWM.Domain.Workspace (toWorkspaceRef) import HWM.Runtime.Cache (getSnapshotGHC) import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_) -import HWM.Runtime.Logging (logIssue) -import HWM.Runtime.Process (exec) import Relude hiding (head, tail) import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute) import System.FilePath (dropExtension, ()) @@ -89,7 +82,7 @@ version <- fromEither ("Invalid version: " <> versionPart) (parse versionPart) pure (pkgName, version) -syncStackYaml :: ConfigT () +syncStackYaml :: ConfigT Status syncStackYaml = do stackYamlPath <- optionsStack <$> askOptions rewrite_ stackYamlPath $ const $ do @@ -115,7 +108,7 @@ createEnvYaml target = do path <- stackPath (Just target) liftIO $ createDirectoryIfMissing True ".hwm/matrix/" - rewrite_ path $ const $ do + _ <- rewrite_ path $ const $ do BuildEnvironment {..} <- getBuildEnvironment Nothing pure Stack @@ -127,56 +120,7 @@ allowNewer = buildAllowNewer, .. } - -stackGenBinary :: PkgName -> FilePath -> [Text] -> ConfigT () -stackGenBinary pkgName dirPath args = do - (success, buildOut) <- runStack (["install", format pkgName, "--local-bin-path", format dirPath] <> args) - unless success $ throwError (fromString $ "Build failed: " <> buildOut) - -runStack :: [Text] -> ConfigT (Bool, String) -runStack = exec "stack" - -sdist :: Pkg -> ConfigT [Issue] -sdist pkg = do - let issueTopic = pkgMemberId pkg - issueMessage = "stack sdist detected Issues. No packages were published." - (isSuccess, out) <- runStack ["sdist", format (pkgName pkg)] - let severity = if isSuccess then findIssue out else Just SeverityError - case severity of - Nothing -> pure [] - Just issueSeverity -> do - issueFile <- logIssue "sdist" issueSeverity [("COMMAND", "stack sdist " <> format (pkgName pkg))] (pack out) - let issueDetails = Just GenericIssue {issueFile} - in pure [Issue {..}] - -upload :: Pkg -> ConfigT (Status, [Issue]) -upload pkg = do - (isSuccess, out) <- runStack ["upload", format (pkgName pkg)] - ( if isSuccess - then pure (Checked, []) - else - ( do - pure - ( Invalid, - [ Issue - { issueTopic = pkgMemberId pkg, - issueMessage = "Package publishing failed:" <> indentBlockNum 4 ("\n\n" <> T.pack out), - issueSeverity = SeverityError, - issueDetails = Just GenericIssue {issueFile = fromMaybe (cabalFile pkg) (hpackFile pkg)} - } - ] - ) - ) - ) - -findIssue :: String -> Maybe Severity -findIssue str = - let ls = map T.strip $ T.lines $ T.toLower $ T.pack str - in case find ("error:" `T.isInfixOf`) ls of - Just _ -> Just SeverityError - Nothing -> case find ("warning:" `T.isInfixOf`) ls of - Just _ -> Just SeverityWarning - Nothing -> Nothing + pure () scanStackFiles :: (MonadIO m, MonadError Issue m) => Options -> FilePath -> m [(Name, Stack)] scanStackFiles opts root = do @@ -196,10 +140,10 @@ buildMatrix :: (MonadIO m, MonadError Issue m) => [Pkg] -> [(Name, Stack)] -> m Environments buildMatrix pkgs (defaultEnv : envs) = do environments <- sortOn (ghc . snd) <$> traverse (inferBuildEnv pkgs) (defaultEnv : envs) - pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList environments, envStack = Just True, envNix = Nothing} + pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList environments, envStack = Just True, envNix = Nothing, envBuilder = Just StackBuilder} buildMatrix _ [] = do let defaultEnv = mkDefaultEnv - pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList [defaultEnv], envStack = Nothing, envNix = Nothing} + pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList [defaultEnv], envStack = Nothing, envNix = Nothing, envBuilder = Nothing} mkDefaultEnv :: (Name, Enviroment) mkDefaultEnv = diff --git a/src/HWM/Runtime/Files.hs b/src/HWM/Runtime/Files.hs --- a/src/HWM/Runtime/Files.hs +++ b/src/HWM/Runtime/Files.hs @@ -10,7 +10,6 @@ statusM, aesonYAMLOptions, select, - remove, addHash, forbidOverride, cleanRelativePath, @@ -19,10 +18,12 @@ Signature, getFileSignature, prepareDir, + syncFile, + rewriteMaybe_, ) where -import Control.Exception (catch, throwIO, tryJust) +import Control.Exception (tryJust) import Control.Monad.Error.Class (MonadError (..)) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson @@ -41,14 +42,14 @@ import Data.Text (toTitle) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as TIO import Data.Yaml (decodeThrow) import Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare, setConfDropNull) -import HWM.Core.Formatting +import HWM.Core.Formatting (Format (..), Status (..)) import HWM.Core.Result (Issue) import Relude hiding (readFile, writeFile) -import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (joinPath, splitDirectories) -import System.IO.Error (isDoesNotExistError) data Signature = Signed Text | Unsigned deriving (Ord, Show) @@ -73,9 +74,6 @@ safeIO :: IO a -> IO (Either String a) safeIO = tryJust (Just . printException) -remove :: (MonadIO m) => FilePath -> m () -remove file = liftIO $ removeFile file `catch` (\e -> unless (isDoesNotExistError e) (throwIO e)) - safeRead :: (MonadIO m) => FilePath -> m (Either String ByteString) safeRead = liftIO . safeIO . readFile @@ -114,12 +112,28 @@ withThrow :: (MonadError Issue m) => m (Either String a) -> m a withThrow x = x >>= either (throwError . fromString) pure -rewrite_ :: (MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) => FilePath -> (Maybe t -> m t) -> m () +rewrite_ :: (MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) => FilePath -> (Maybe t -> m t) -> m Status rewrite_ pkg f = do - original <- safeRead pkg - yaml <- fromEither original >>= mapYaml f - withThrow (safeWrite pkg (serializeYaml yaml)) + prevYaml <- safeRead pkg >>= fromEither + nextYaml <- mapYaml f prevYaml + let same = Just (toJSON nextYaml) == (toJSON <$> prevYaml) + if same + then pure Checked + else withThrow (safeWrite pkg (serializeYaml nextYaml)) $> Updated +rewriteMaybe_ :: (MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) => FilePath -> (Maybe t -> m (Maybe t)) -> m Status +rewriteMaybe_ pkg f = do + prevYaml <- safeRead pkg >>= fromEither + maybeNext <- f (getData <$> prevYaml) + case maybeNext of + Nothing -> pure Checked -- nothing to change, so we consider it checked + Just next -> do + nextYaml <- mapYaml (const (pure next)) prevYaml + let same = Just (toJSON nextYaml) == (toJSON <$> prevYaml) + if same + then pure Checked + else withThrow (safeWrite pkg (serializeYaml nextYaml)) $> Updated + statusM :: (MonadIO m) => FilePath -> m t -> m Status statusM pkg m = do before <- safeRead pkg @@ -240,3 +254,14 @@ prepareDir :: (MonadIO m) => FilePath -> m () prepareDir dir = liftIO $ createDirectoryIfMissing True dir + +syncFile :: (MonadIO m) => FilePath -> Text -> m Status +syncFile path newFile = do + exist <- liftIO $ doesFileExist path + old <- + if exist + then Just <$> liftIO (TIO.readFile path) + else pure Nothing + if old == Just newFile + then pure Checked + else liftIO $ TIO.writeFile path newFile $> Updated diff --git a/src/HWM/Runtime/Network.hs b/src/HWM/Runtime/Network.hs --- a/src/HWM/Runtime/Network.hs +++ b/src/HWM/Runtime/Network.hs @@ -1,21 +1,31 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} -module HWM.Runtime.Network (uploadToGitHub, getGHUploadUrl) where +module HWM.Runtime.Network (uploadToGitHub, getGHUploadUrl, uploadToHackage, getHackageToken) where +import Control.Exception (try) import Control.Monad.Except (MonadError (..)) +import Control.Retry (exponentialBackoff, limitRetries) import Data.Aeson (FromJSON) import qualified Data.Text as T -import HWM.Core.Result (Issue (..)) +import HWM.Core.Pkg (Pkg (..)) +import HWM.Core.Result (Issue (..), Severity (..)) import HWM.Domain.Config (Config (..)) +import HWM.Domain.ConfigT (ConfigT) +import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Response (responseStatus)) +import Network.HTTP.Client.MultipartFormData (partFileSource) import Network.HTTP.Req +import Network.HTTP.Types (Status (..)) import Relude import System.FilePath (takeFileName) +import System.Timeout (timeout) import Text.URI (mkURI) +import UnliftIO.Retry (capDelay) getGitHubToken :: (MonadIO m, MonadError Issue m) => m Text getGitHubToken = do @@ -25,67 +35,106 @@ (pure . T.pack) maybeToken +ghAuth :: Text -> Option 'Https +ghAuth token = + header "Authorization" ("Bearer " <> encodeUtf8 token) + <> header "User-Agent" "hwm-tool" + +hackageAuth :: Text -> Option 'Https +hackageAuth token = + header "Authorization" ("X-ApiKey " <> encodeUtf8 token) + <> header "User-Agent" "hwm-tool" + uploadToGitHub :: (MonadIO m, MonadError Issue m) => Text -> FilePath -> m () uploadToGitHub uploadUrl filePath = do token <- getGitHubToken liftIO $ runReq defaultHttpConfig $ do - uri <- liftIO $ mkURI uploadUrl - case useHttpsURI uri of - Just (url, opts) -> do - let fileName = T.pack $ takeFileName filePath - void - $ req - POST - url - (ReqBodyFile filePath) -- Raw bytes, no multipart wrapping - ignoreResponse - ( opts - <> queryParam "name" (Just fileName) -- Required by GitHub - <> header "Authorization" ("Bearer " <> encodeUtf8 token) - <> header "Content-Type" "application/octet-stream" -- Crucial! - <> 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. + (url, opts) <- withURI uploadUrl + void + $ req + POST + url + (ReqBodyFile filePath) + ignoreResponse + ( opts + <> queryParam "name" (Just $ T.pack $ takeFileName filePath) + <> ghAuth token + <> header "Content-Type" "application/octet-stream" + ) data GitHubRelease = GitHubRelease { name :: Text, upload_url :: Text } - deriving (Show, Generic) - --- 2. Automatically derive the JSON parser -instance FromJSON GitHubRelease + deriving (Show, Generic, FromJSON) --- 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" - ) + (url, opts) <- withURI ("https://api.github.com/repos/" <> gh <> "/releases/tags/" <> tag) + r <- req GET url NoReqBody jsonResponse (opts <> ghAuth token <> header "Accept" "application/vnd.github+json") + let rawUrl = upload_url (responseBody r) + pure $ T.takeWhile (/= '{') rawUrl - -- Extract the raw URL from the parsed JSON object - let rawUrl = upload_url (responseBody r) +withURI :: (MonadIO m) => Text -> m (Url Https, Option scheme) +withURI u = do + uri <- liftIO $ mkURI u + case useHttpsURI uri of + Just (url, opts) -> pure (url, opts) + Nothing -> error ("URLs must be HTTPS: " <> show u) - -- Strip the "{?name,label}" template suffix before returning - return $ T.takeWhile (/= '{') rawUrl - Nothing -> error "GitHub API URLs must be HTTPS" +mkSecond :: Int -> Int +mkSecond n = n * 1000000 + +hwmConfig :: HttpConfig +hwmConfig = + let policy = + capDelay (mkSecond 5) (exponentialBackoff (mkSecond 1)) + <> limitRetries 3 + in defaultHttpConfig {httpConfigRetryPolicy = policy} + +safeReq :: (MonadIO m) => Pkg -> Text -> (Status -> Issue) -> IO b -> m (Either Issue b) +safeReq pkg errMsg f action = do + res <- liftIO $ timeout (mkSecond 90) $ try action + case res of + Nothing -> pure $ Left $ Issue (pkgMemberId pkg) SeverityError (errMsg <> " (Timeout)") Nothing + Just (Left (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException r _)))) -> pure $ Left $ f (responseStatus r) + Just (Left e) -> pure $ Left $ networkError pkg e + Just (Right a) -> pure $ Right a + +getHackageToken :: (MonadIO m, MonadError Issue m) => m Text +getHackageToken = do + maybeToken <- liftIO $ lookupEnv "HACKAGE_AUTH_TOKEN" + maybe + (throwError "HACKAGE_AUTH_TOKEN environment variable not set. Please set it to a valid Hackage API Token.") + (pure . T.pack) + maybeToken + +uploadToHackage :: Text -> Pkg -> FilePath -> ConfigT [Issue] +uploadToHackage token pkg tarballPath = do + let auth = hackageAuth token + let url = https "hackage.haskell.org" /: "packages" + body <- reqBodyMultipart [partFileSource "package" tarballPath] + result <- + safeReq pkg "Hackage Upload Failed" (handleHttpError pkg) + $ runReq hwmConfig + $ req POST url body ignoreResponse auth + pure $ either pure (const []) result + +handleHttpError :: Pkg -> Status -> Issue +handleHttpError pkg status = case statusCode status of + 409 -> warn pkg "Version already exists on Hackage. Skipping." + 401 -> err pkg "Invalid Hackage API Token." + 413 -> err pkg "Package tarball is too large for Hackage." + _ -> err pkg $ "Hackage returned: " <> show (statusCode status) + +networkError :: (Show a) => Pkg -> a -> Issue +networkError pkg _ = Issue (pkgMemberId pkg) SeverityError "Hackage Connection Error" Nothing + +err :: Pkg -> Text -> Issue +err pkg msg = Issue (pkgMemberId pkg) SeverityError msg Nothing + +warn :: Pkg -> Text -> Issue +warn pkg msg = Issue (pkgMemberId pkg) SeverityWarning msg Nothing diff --git a/src/HWM/Runtime/UI.hs b/src/HWM/Runtime/UI.hs --- a/src/HWM/Runtime/UI.hs +++ b/src/HWM/Runtime/UI.hs @@ -26,6 +26,7 @@ runSpinner, printGenTable, forTable, + statusTableM, ) where @@ -36,7 +37,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import HWM.Core.Common (Name) -import HWM.Core.Formatting (Color (..), Format (..), Status (..), chalk, indentBlockNum, padDots, renderSummaryStatus, subPathSign) +import HWM.Core.Formatting (Color (..), Format (..), Status (..), chalk, indentBlockNum, padDots, renderSummaryStatus, statusIcon, subPathSign) import HWM.Core.Result ( Issue (..), IssueDetails (..), @@ -134,11 +135,18 @@ tableM_ :: (MonadUI m) => [(Text, m Text)] -> m () tableM_ rows = forHLTable rows (second ((,()) <$>)) $> () +statusTableM :: (MonadUI m) => [(Text, m Status)] -> m () +statusTableM = tableM_ . map (second render) + where + render s = statusIcon <$> s + sectionTableM :: (MonadUI m) => Text -> [(Text, m Text)] -> m () sectionTableM title = section title . tableM_ -sectionConfig :: (MonadUI m) => [(Text, m Text)] -> m () -sectionConfig = section "config" . tableM_ +sectionConfig :: (MonadUI m) => [(Text, m Status)] -> m () +sectionConfig = section "config" . tableM_ . map (second render) + where + render s = statusIcon <$> s printGenTable :: (MonadUI m) => [[Text]] -> m () printGenTable rows = diff --git a/test/Commands/Init.hs b/test/Commands/Init.hs deleted file mode 100644 --- a/test/Commands/Init.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Commands.Init (testInit) where - -import Test.Hspec (Spec, describe, it) -import Utils.Golden (Golden (..), goldenTest) - -testInit :: Spec -testInit = describe "init" $ do - it "inits a simple workspace" $ - goldenTest - Golden - { cmd = "init", - project = "simple", - scenario = "init/simple" - } - it "inits a huge monorepo" $ - goldenTest - Golden - { cmd = "init", - project = "morpheus", - scenario = "init/cabal" - } diff --git a/test/Commands/Sync.hs b/test/Commands/Sync.hs deleted file mode 100644 --- a/test/Commands/Sync.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Commands.Sync (testSync) where - -import Test.Hspec (Spec, describe, it) -import Utils.Golden (Golden (..), goldenTest) - -testSync :: Spec -testSync = describe "sync" $ do - it "syncs a simple workspace" $ - goldenTest - Golden - { cmd = "sync", - project = "simple", - scenario = "sync/simple" - } - it "syncs a cabal-only workspace" $ - goldenTest - Golden - { cmd = "sync", - project = "morpheus", - scenario = "sync/cabal" - } - it "syncs a nix workspace" $ - goldenTest - Golden - { cmd = "sync", - project = "morpheus", - scenario = "sync/nix" - } - it "syncs a stack workspace" $ - goldenTest - Golden - { cmd = "sync", - project = "morpheus", - scenario = "sync/stack" - } diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main (main) where - -import Commands.Init (testInit) -import Commands.Sync (testSync) -import Test.Hspec (hspec) - -main :: IO () -main = hspec $ do - testInit - testSync diff --git a/test/Utils/Core.hs b/test/Utils/Core.hs deleted file mode 100644 --- a/test/Utils/Core.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Utils.Core (assertNotModified, assertWorkspaceNotModified, copyLocalFiles, inWorkDir, diff, runHWM) where - -import Control.Concurrent (threadDelay) -import qualified Data.List as S -import qualified GHC.IO.Exception as System.Exit -import Relude -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory, getModificationTime, listDirectory, makeAbsolute, setCurrentDirectory) -import System.Directory.Internal.Prelude (bracket) -import System.FilePath (takeExtension, ()) -import System.IO.Temp (withSystemTempDirectory) -import System.Process (callCommand, readCreateProcessWithExitCode, shell) -import Test.Hspec (Expectation, expectationFailure, shouldBe) - -assertNotModified :: FilePath -> IO () -> Expectation -assertNotModified path action = do - oldTime <- getModificationTime path - threadDelay 1100000 - action - newTime <- getModificationTime path - newTime `shouldBe` oldTime - -assertWorkspaceNotModified :: FilePath -> IO a -> Expectation -assertWorkspaceNotModified root action = do - managedFiles <- findManagedFiles root - oldTimes <- mapM (\p -> (p,) <$> getModificationTime p) managedFiles - threadDelay 1100000 - _ <- action - newTimes <- mapM (\p -> (p,) <$> getModificationTime p) managedFiles - newTimes `shouldBe` oldTimes - --- | Helper to find files HWM cares about (.cabal, .yaml, .nix, .project) -findManagedFiles :: FilePath -> IO [FilePath] -findManagedFiles dir = do - contents <- listDirectory dir - paths <- mapM (\path -> let p = dir path in (p,) <$> doesDirectoryExist p) contents - let files = [p | (p, isDir) <- paths, not isDir, isManagedExtension p] - subDirFiles <- concat <$> mapM (\(p, isDir) -> if isDir then findManagedFiles p else return []) paths - return $ files ++ subDirFiles - where - isManagedExtension p = takeExtension p `elem` [".cabal", ".yaml", ".nix", ".project"] - -copyLocalFiles :: FilePath -> IO () -copyLocalFiles = copyDir "." - -copyDir :: FilePath -> FilePath -> IO () -copyDir src dst = do - createDirectoryIfMissing True dst - callCommand $ "cp -r " <> src <> " " <> dst - -copyFrom :: FilePath -> FilePath -> IO () -copyFrom src = copyDir (src <> "/.") - -inWorkDir :: FilePath -> FilePath -> IO a -> IO () -inWorkDir project scenario m = do - projectDir <- makeAbsolute ("test/projects/" project) - overridesDir <- makeAbsolute (scenario "overrides") - withSystemTempDirectory "hwm-golden" $ \tmpDir -> do - let workDir = tmpDir "work" - copyFrom projectDir workDir - whenM (doesDirectoryExist overridesDir) $ copyFrom overridesDir workDir - bracket getCurrentDirectory setCurrentDirectory $ \_ -> do - setCurrentDirectory workDir - m $> () - -diff :: FilePath -> [FilePath] -> IO () -diff expectedDir ignoreList = do - let ignoreFlags = S.unwords ["-x " ++ p | p <- ignoreList] - (diffCode, diffOut, _) <- - readCreateProcessWithExitCode - (shell $ "diff -ruN " ++ ignoreFlags ++ " " ++ expectedDir ++ " .") - "" - unless (diffCode == System.Exit.ExitSuccess) - $ expectationFailure - $ "File diff failed:\n" - <> diffOut - -runHWM :: String -> IO String -runHWM cmd = do - (exitCode, out, err) <- - readCreateProcessWithExitCode - (shell $ "stack exec hwm -- " <> cmd) - "" - unless (exitCode == System.Exit.ExitSuccess) - $ expectationFailure ("Command failed with stdout: " <> out <> "stderr: " <> err) - return out diff --git a/test/Utils/Golden.hs b/test/Utils/Golden.hs deleted file mode 100644 --- a/test/Utils/Golden.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Utils.Golden (Golden (..), goldenTest) where - -import Relude -import System.Directory (makeAbsolute, removePathForcibly) -import System.FilePath (()) -import qualified System.IO as IO -import Test.Hspec (Expectation, shouldBe) -import Utils.Core (copyLocalFiles, diff, inWorkDir, runHWM) - -data Golden = Golden - { cmd :: String, - scenario :: FilePath, - project :: FilePath - } - -isUpdateMode :: IO Bool -isUpdateMode = (== Just "1") <$> lookupEnv "GOLDEN_UPDATE" - -goldenTest :: Golden -> Expectation -goldenTest Golden {..} = do - scenarioDir <- makeAbsolute $ "test/golden/" scenario - let expectedDir = scenarioDir "expected" - let stdoutFile = scenarioDir "stdout.ansi" - updateMode <- isUpdateMode - inWorkDir project scenarioDir $ do - out <- runHWM cmd - if updateMode - then do - removePathForcibly expectedDir - copyLocalFiles expectedDir - IO.writeFile stdoutFile out - else do - diff expectedDir [".hwm", ".stack-work", "dist-newstyle", "*.log"] - expectedStdout <- IO.readFile stdoutFile - out `shouldBe` expectedStdout