diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,20 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.9.0.0 + +* Remove `arch-hs-submit` executable + +* Add `arch-hs-sync` executable, which has two commands: + * `arch-hs-sync submit` - the same as `arch-hs-submit` previously + * `arch-hs-sync check` - check version inconsistencies between [community] and Hackage + +* Improve CLI options: + * values of `--skip` and `--flag` are no longer separated by comma + * the options can be set many times, for example: `arch-hs -f packageA:flagA:true -f packageB:flagB:false` + +* Update name preset + ## 0.8.0.0 * Fix the bug that unable to run with dependency-free packages diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -87,66 +87,7 @@ ⓘ Loading community.db from libalpm ⓘ Start running... ⓘ Solved: -Cabal ✔ [community] -ChasingBottoms ✔ [community] -Diff ✔ [community] -HUnit ✔ [community] -QuickCheck ✔ [community] -StateVar ✔ [community] -adjunctions ✔ [community] -aeson ✔ [community] -ansi-terminal ✔ [community] -ansi-wl-pprint ✔ [community] -assoc ✔ [community] -async ✔ [community] -attoparsec ✔ [community] -base-compat ✔ [community] -base-compat-batteries ✔ [community] -base-orphans ✔ [community] -base16-bytestring ✔ [community] -base64-bytestring ✔ [community] -bifunctors ✔ [community] -binary ✔ [community] -blaze-builder ✔ [community] -blaze-html ✔ [community] -blaze-markup ✔ [community] -bytestring ✔ [community] -bytestring-handle ✔ [community] -cabal-doctest ✔ [community] -call-stack ✔ [community] -case-insensitive ✔ [community] -charset ✔ [community] -clock ✔ [community] -code-page ✔ [community] -colour ✔ [community] -comonad ✔ [community] -concurrent-output ✔ [community] -conduit ✔ [community] -conduit-extra ✔ [community] -constraints ✔ [community] -containers ✔ [community] -contravariant ✔ [community] -data-default ✔ [community] -data-default-instances-containers ✔ [community] -data-default-instances-dlist ✔ [community] -data-default-instances-old-locale ✔ [community] -data-fix ✔ [community] -deepseq ✔ [community] -directory ✔ [community] -distributive ✔ [community] -dlist ✔ [community] -doctest ✔ [community] -exceptions ✔ [community] -filepath ✔ [community] -fingertree ✔ [community] -foldl ✔ [community] -free ✔ [community] -generic-deriving ✔ [community] -ghc ✔ [community] -ghc-boot ✔ [community] -ghc-paths ✔ [community] -ghci ✔ [community] -gi-cairo ✔ [community] +... gi-gdk ✘ ├─Cabal (Setup) ✔ [community] ├─bytestring (Lib) ✔ [community] @@ -227,138 +168,7 @@ ├─haskell-gi-overloading (Lib) ✔ [community] ├─text (Lib) ✔ [community] └─transformers (Lib) ✔ [community] -hashable ✔ [community] -hashable-time ✔ [community] -haskell-gi ✔ [community] -haskell-gi-base ✔ [community] -haskell-src-exts ✔ [community] -hedgehog ✔ [community] -hpc ✔ [community] -hspec ✔ [community] -hspec-core ✔ [community] -hspec-discover ✔ [community] -hspec-expectations ✔ [community] -hspec-meta ✔ [community] -indexed-traversable ✔ [community] -integer-logarithms ✔ [community] -invariant ✔ [community] -kan-extensions ✔ [community] -lens ✔ [community] -libxml ✔ [community] -lifted-async ✔ [community] -lifted-base ✔ [community] -logging-facade ✔ [community] -logict ✔ [community] -math-functions ✔ [community] -mmorph ✔ [community] -mockery ✔ [community] -monad-control ✔ [community] -mono-traversable ✔ [community] -mtl ✔ [community] -mwc-random ✔ [community] -nanospec ✔ [community] -network ✔ [community] -optparse-applicative ✔ [community] -parallel ✔ [community] -parsec ✔ [community] -parsers ✔ [community] -pcre-light ✔ [community] -pgp-wordlist ✔ [community] -pretty ✔ [community] -pretty-show ✔ [community] -prettyprinter ✔ [community] -prettyprinter-ansi-terminal ✔ [community] -primitive ✔ [community] -process ✔ [community] -profunctors ✔ [community] -quickcheck-classes-base ✔ [community] -quickcheck-instances ✔ [community] -quickcheck-io ✔ [community] -quickcheck-unicode ✔ [community] -random ✔ [community] -reducers ✔ [community] -reflection ✔ [community] -regex-base ✔ [community] -regex-posix ✔ [community] -regex-tdfa ✔ [community] -resourcet ✔ [community] -safe ✔ [community] -scientific ✔ [community] -semigroupoids ✔ [community] -setenv ✔ [community] -silently ✔ [community] -smallcheck ✔ [community] -split ✔ [community] -splitmix ✔ [community] -stm ✔ [community] -streaming-commons ✔ [community] -strict ✔ [community] -stringbuilder ✔ [community] -syb ✔ [community] -tagged ✔ [community] -tar ✔ [community] -tasty ✔ [community] -tasty-ant-xml ✔ [community] -tasty-expected-failure ✔ [community] -tasty-golden ✔ [community] -tasty-hedgehog ✔ [community] -tasty-hunit ✔ [community] -tasty-quickcheck ✔ [community] -tasty-smallcheck ✔ [community] -tasty-th ✔ [community] -template-haskell ✔ [community] -temporary ✔ [community] -terminal-size ✔ [community] -test-framework ✔ [community] -test-framework-hunit ✔ [community] -test-framework-quickcheck2 ✔ [community] -text ✔ [community] -tf-random ✔ [community] -th-abstraction ✔ [community] -these ✔ [community] -time ✔ [community] -time-compat ✔ [community] -transformers-base ✔ [community] -transformers-compat ✔ [community] -tree-diff ✔ [community] -trifecta ✔ [community] -typed-process ✔ [community] -unix ✔ [community] -unix-compat ✔ [community] -unliftio ✔ [community] -unliftio-core ✔ [community] -unordered-containers ✔ [community] -utf8-string ✔ [community] -uuid-types ✔ [community] -vector ✔ [community] -vector-algorithms ✔ [community] -vector-th-unbox ✔ [community] -wcwidth ✔ [community] -wl-pprint-annotated ✔ [community] -xdg-basedir ✔ [community] -xml ✔ [community] -xml-conduit ✔ [community] -xml-types ✔ [community] -zlib ✔ [community] -array ✔ [community] -transformers ✔ [community] -semigroups ✔ [community] -void ✔ [community] -integer-gmp ✔ [community] -hsc2hs ✔ [community] -type-equality ✔ [community] -data-default-class ✔ [community] -old-locale ✔ [community] -ghc-boot-th ✔ [community] -terminfo ✔ [community] -haskell-gi-overloading ✔ [community] -happy ✔ [community] -erf ✔ [community] -simple-reflect ✔ [community] -haskell-lexer ✔ [community] -unbounded-delays ✔ [community] -hostname ✔ [community] -extensible-exceptions ✔ [community] +... ⓘ Recommended package order: 1. gi-glib @@ -516,12 +326,13 @@ ### Extra Cabal Files ``` -$ arch-hs -e ~/TARGET/TARGET.cabal TARGET +$ arch-hs -e ~/TARGET TARGET ``` **For Testing Purposes Only** -Using `-e` can include extra `.cabal` files as supplementary. Useful when the `TARGET` hasn't been released to hackage. +Using `-e` can include extra `.cabal` files as supplementary. +Useful when the `TARGET` hasn't been released to hackage. ### Trace @@ -555,10 +366,6 @@ ### Alpm -``` -$ arch-hs --alpm TARGET -``` - See [Alpm Support](#Alpm-Support). ### Force @@ -698,9 +505,9 @@ `arch-hs-diff` does not require hackage db, it downloads cabal files from hackage server instead. -## Submit +## Sync -For hackage distribution maintainers only. +For hackage distribution maintainers only, see `arch-hs-sync --help` for details. ## Limitations @@ -724,8 +531,8 @@ ``` This flag is enabled by default in `arch-hs` Arch Linux package. -Compiled with `alpm`, `arch-hs` can accept runtime flag `--alpm`. -**That said, if you want to use alpm to boost `arch-hs`, you need compile `arch-hs` with cabal flag `alpm`, and pass `--aplm` to `arch-hs` when running.** +Compiled with `alpm`, `arch-hs` uses alpm to load pacman databases by default. +In this case, the CLI flag `--no-alpm-community` and `--no-alpm-files` can be used to disable this feature. > When `alpm` is enabled, `arch-hs` will lose the capability of specifying the path of `community.db` and directory of files db. diff --git a/app/Args.hs b/app/Args.hs --- a/app/Args.hs +++ b/app/Args.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,26 +7,19 @@ ) where -import qualified Data.Map.Strict as Map import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.OptionReader +import Distribution.ArchHs.Options import Distribution.ArchHs.Types - -#ifndef ALPM -import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) -import Distribution.ArchHs.FilesDB (defaultFilesDBDir) -#endif +import Distribution.ArchHs.Utils (archHsVersion) data Options = Options - { optHackagePath :: FilePath, -#ifndef ALPM - optCommunityDBPath :: FilePath, - optFilesDBPath :: FilePath, -#endif + { optHackage :: HackageDBOptions, + optCommunityDB :: CommunityDBOptions, + optFilesDB :: FilesDBOptions, optOutputDir :: FilePath, optFlags :: FlagAssignments, optSkip :: [String], - optExtraCabalPath :: [FilePath], + optExtraCabalDirs :: [FilePath], optAur :: Bool, optStdoutTrace :: Bool, optFileTrace :: FilePath, @@ -35,42 +27,15 @@ optForce :: Bool, optMetaDir :: FilePath, optJson :: FilePath, -#ifdef ALPM - optAlpm :: Bool, -#endif optTarget :: PackageName } - deriving stock (Show) cmdOptions :: Parser Options cmdOptions = Options - <$> strOption - ( long "hackage" - <> metavar "PATH" - <> short 'h' - <> help "Path to hackage index tarball" - <> showDefault - <> value "" - ) -#ifndef ALPM - <*> strOption - ( long "community" - <> metavar "PATH" - <> short 'c' - <> help "Path to community.db" - <> showDefault - <> value defaultCommunityDBPath - ) - <*> strOption - ( long "files" - <> metavar "PATH" - <> short 'f' - <> help "Path of dir that includes core.files, extra.files and community.files" - <> showDefault - <> value defaultFilesDBDir - ) -#endif + <$> hackageDBOptionsParser + <*> communityDBOptionsParser + <*> filesDBOptionsParser <*> strOption ( long "output" <> metavar "PATH" @@ -78,29 +43,22 @@ <> help "Output path to generated PKGBUILD files (empty means dry run)" <> value "" ) - <*> option - optFlagReader - ( long "flags" - <> metavar "package_name:flag_name:true|false,..." - <> short 'f' - <> help "Flag assignments for packages - e.g. inline-c:gsl-example:true (separated by ',')" - <> value Map.empty - ) - <*> option - optSkippedReader - ( long "skip" - <> metavar "component_name,..." - <> short 's' - <> help "Skip a runnable component (executable, test suit, or benchmark) in dependency calculation" - <> value [] + <*> optFlagAssignmentParser + <*> many + ( strOption + ( long "skip" + <> metavar "component_name" + <> short 's' + <> help "Skip a runnable component (executable, test suit, or benchmark) in dependency calculation" + ) ) - <*> option - optExtraCabalReader - ( long "extra" - <> metavar "PATH_1,..." - <> short 'e' - <> help "Extra cabal files' path - e.g. /home/berberman/arch-hs/arch-hs.cabal" - <> value [] + <*> many + ( strOption + ( long "extra" + <> metavar "PATH_1,..." + <> short 'e' + <> help "Paths to directories that contain extra cabal files to include - e.g. /home/berberman/arch-hs" + ) ) <*> switch ( long "aur" @@ -137,20 +95,15 @@ <> help "Path to json output (empty means do not write output as json to file)" <> value "" ) -#ifdef ALPM - <*> switch - ( long "alpm" - <> help "Use libalpm to parse community db" - ) -#endif <*> argument optPackageNameReader (metavar "TARGET") runArgsParser :: IO Options -runArgsParser = - execParser $ - info - (cmdOptions <**> helper) - ( fullDesc - <> progDesc "Try to reach the TARGET QAQ." - <> header "arch-hs - a program generating PKGBUILD for hackage packages." - ) +runArgsParser = do + (x, ()) <- + simpleOptions + archHsVersion + "arch-hs - generate PKGBUILD for Haskell packages in Hackage" + "arch-hs is a CLI tool automating the PKGBUILD generation for Haskell packages, with dependency resolving and template filling" + cmdOptions + empty + pure x diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -30,6 +29,7 @@ import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local import Distribution.ArchHs.Name +import Distribution.ArchHs.Options import Distribution.ArchHs.PP import qualified Distribution.ArchHs.PkgBuild as N import Distribution.ArchHs.Types @@ -309,43 +309,23 @@ when optUusi $ printInfo "You passed --uusi, uusi will become makedepends of each package" - hackagePath <- if null optHackagePath then lookupHackagePath else return optHackagePath - - printInfo $ "Loading hackage from" <+> pretty hackagePath - - hackage <- loadHackageDB hackagePath + hackage <- loadHackageDBFromOptions optHackage - let isExtraEmpty = null optExtraCabalPath + let isExtraEmpty = null optExtraCabalDirs + optExtraCabal <- mapM findCabalFile optExtraCabalDirs unless isExtraEmpty $ - printInfo $ "You added" <+> hsep (punctuate comma $ pretty . takeFileName <$> optExtraCabalPath) <+> "as extra cabal file(s), starting parsing right now" + printInfo $ "You added" <+> hsep (punctuate comma $ pretty . takeFileName <$> optExtraCabal) <+> "as extra cabal file(s), starting parsing right now" - parsedExtra <- mapM parseCabalFile optExtraCabalPath + parsedExtra <- mapM parseCabalFile optExtraCabal let newHackage = foldr insertDB hackage parsedExtra -#ifdef ALPM - let src = T.pack $ if optAlpm then "libalpm" else defaultCommunityDBPath - printInfo $ "Loading community.db from " <> pretty src - community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath -#else - printInfo $ "Loading community.db from" <+> pretty optCommunityDBPath - community <- loadCommunityDB optCommunityDBPath -#endif + community <- loadCommunityDBFromOptions optCommunityDB printInfo "Start running..." - empty <- newIORef Set.empty - - let loadF db = do -#ifdef ALPM - printInfo $ "Loading" <+> ppDBKind db <+> "files from libalpm" - if optAlpm then loadFilesDBFFI db else loadFilesDB db defaultFilesDBDir -#else - printInfo $ "Loading" <+> ppDBKind db <+> "files from" <+> pretty optFilesDBPath - loadFilesDB db optFilesDBPath - -#endif + ref <- newIORef Set.empty manager <- newTlsManager @@ -355,9 +335,9 @@ optFlags optStdoutTrace optFileTrace - empty + ref manager - (app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir optJson loadF) + (app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir optJson (loadFilesDBFromOptions optFilesDB)) & printAppResult ----------------------------------------------------------------------------- diff --git a/arch-hs.cabal b/arch-hs.cabal --- a/arch-hs.cabal +++ b/arch-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: arch-hs -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -39,9 +39,9 @@ , aeson ^>=1.5.4 , algebraic-graphs ^>=0.5 , arch-web ^>=0.1.0 - , base >=4.12 && <5 + , base >=4.12 && <5 , bytestring - , Cabal >=3.2 && <3.5 + , Cabal >=3.2 && <3.5 , conduit ^>=1.3.2 , conduit-extra ^>=1.3.5 , containers @@ -56,7 +56,7 @@ , microlens ^>=0.4.11 , microlens-th ^>=0.4.3 , neat-interpolation ^>=0.5.1 - , optparse-applicative ^>=0.16.0 + , optparse-simple ^>=0.1.1.3 , polysemy , prettyprinter ^>=1.7.0 , prettyprinter-ansi-terminal ^>=1.1.2 @@ -95,6 +95,7 @@ library import: common-options hs-source-dirs: src + autogen-modules: Paths_arch_hs exposed-modules: Distribution.ArchHs.Aur Distribution.ArchHs.CommunityDB @@ -105,14 +106,16 @@ Distribution.ArchHs.Internal.Prelude Distribution.ArchHs.Local Distribution.ArchHs.Name - Distribution.ArchHs.OptionReader + Distribution.ArchHs.Options Distribution.ArchHs.PkgBuild Distribution.ArchHs.PkgDesc Distribution.ArchHs.PP Distribution.ArchHs.Types Distribution.ArchHs.Utils - other-modules: Distribution.ArchHs.Internal.NamePresetLoader + other-modules: + Distribution.ArchHs.Internal.NamePresetLoader + Paths_arch_hs executable arch-hs import: common-options @@ -129,14 +132,23 @@ import: common-options hs-source-dirs: diff main-is: Main.hs - other-modules: Diff + other-modules: + Args + Diff + build-depends: arch-hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -executable arch-hs-submit +executable arch-hs-sync import: common-options - hs-source-dirs: submit + hs-source-dirs: sync main-is: Main.hs - other-modules: Submit + other-modules: + Args + Check + Submit + Submit.CSV + Utils + build-depends: arch-hs ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/data/NAME_PRESET.json b/data/NAME_PRESET.json --- a/data/NAME_PRESET.json +++ b/data/NAME_PRESET.json @@ -6,12 +6,14 @@ "c2hs": "c2hs", "haskell-cabal": "Cabal", "cabal-install": "cabal-install", + "cabal-plan": "cabal-plan", "cgrep": "cgrep", "clash-ghc": "clash-ghc", "cryptol": "cryptol", "darcs": "darcs", "dhall": "dhall", "dhall-bash": "dhall-bash", + "dhall-docs": "dhall-docs", "dhall-json": "dhall-json", "dhall-lsp-server": "dhall-lsp-server", "dhall-yaml": "dhall-yaml", @@ -45,6 +47,7 @@ "haskell-lexer": "haskell-lexer", "haskell-listlike": "ListLike", "haskell-lsp0": "haskell-lsp", + "haskell-lsp0-types": "haskell-lsp-types", "haskell-missingh": "MissingH", "haskell-monadlib": "monadLib", "haskell-monadrandom": "MonadRandom", @@ -53,8 +56,6 @@ "haskell-hsyaml": "HsYAML", "haskell-hsyaml-aeson": "HsYAML-aeson", "haskell-libbf": "libBF", - "haskell-lsp": "haskell-lsp", - "haskell-lsp-types": "haskell-lsp-types", "haskell-memotrie": "MemoTrie", "haskell-monadprompt": "MonadPrompt", "haskell-rsa": "RSA", @@ -69,6 +70,7 @@ "haskell-src-meta": "haskell-src-meta", "haskell-statevar": "StateVar", "haskell-stmonadtrans": "STMonadTrans", + "haskell-stream": "Stream", "haskell-unixutils": "Unixutils", "haskell-x11": "X11", "haskell-x11-xft": "X11-xft", diff --git a/diff/Args.hs b/diff/Args.hs new file mode 100644 --- /dev/null +++ b/diff/Args.hs @@ -0,0 +1,39 @@ +module Args + ( Options (..), + cmdOptions, + runArgsParser, + ) +where + +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Options +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils (archHsVersion) + +data Options = Options + { optFlags :: FlagAssignments, + optCommunityDB :: CommunityDBOptions, + optPackageName :: PackageName, + optVersionA :: Version, + optVersionB :: Version + } + +cmdOptions :: Parser Options +cmdOptions = + Options + <$> optFlagAssignmentParser + <*> communityDBOptionsParser + <*> argument optPackageNameReader (metavar "TARGET") + <*> argument optVersionReader (metavar "VERSION_A") + <*> argument optVersionReader (metavar "VERSION_B") + +runArgsParser :: IO Options +runArgsParser = do + (x, ()) <- + simpleOptions + archHsVersion + "arch-hs-diff - create diff between different versions of package description" + "arch-hs-diff is a CLI tool that shows the differences of package description between two versions of a package, and remind us if some required packages in community repo can't satisfy the version constraints, or they are non-existent" + cmdOptions + empty + pure x diff --git a/diff/Diff.hs b/diff/Diff.hs --- a/diff/Diff.hs +++ b/diff/Diff.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Diff ( diffCabal, - Options (..), - runArgsParser, ) where @@ -17,7 +14,6 @@ import Distribution.ArchHs.Core (evalConditionTree) import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.OptionReader import Distribution.ArchHs.PP import Distribution.ArchHs.Types import Distribution.ArchHs.Utils @@ -29,62 +25,6 @@ import Distribution.Utils.ShortText (fromShortText) import Network.HTTP.Client -#ifndef ALPM -import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) -#endif - -data Options = Options - { optFlags :: FlagAssignments, -#ifdef ALPM - optAlpm :: Bool, -#else - optCommunityDBPath :: FilePath, -#endif - optPackageName :: PackageName, - optVersionA :: Version, - optVersionB :: Version - } - -cmdOptions :: Parser Options -cmdOptions = - Options - <$> option - optFlagReader - ( long "flags" - <> metavar "package_name:flag_name:true|false,..." - <> short 'f' - <> help "Flag assignments for packages - e.g. inline-c:gsl-example:true (separated by ',')" - <> value Map.empty - ) -#ifndef ALPM - <*> strOption - ( long "community" - <> metavar "PATH" - <> short 'c' - <> help "Path to community.db" - <> showDefault - <> value defaultCommunityDBPath - ) -#else - <*> switch - ( long "alpm" - <> help "Use libalpm to parse community db" - ) -#endif - <*> argument optPackageNameReader (metavar "TARGET") - <*> argument optVersionReader (metavar "VERSION_A") - <*> argument optVersionReader (metavar "VERSION_B") - -runArgsParser :: IO Options -runArgsParser = - execParser $ - info - (cmdOptions <**> helper) - ( fullDesc - <> progDesc "Try to reach the TARGET QAQ." - <> header "arch-hs-diff - a program creating diff between different versions of a cabal file." - ) - ----------------------------------------------------------------------------- -- Duplicated from Core.hs with modifications. @@ -126,7 +66,7 @@ collectTestDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectTestDeps = collectComponentialDeps condTestSuites -collectSubLibDeps :: Members [FlagAssignmentsEnv,Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) +collectSubLibDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectSubLibDeps = collectComponentialDeps condSubLibraries collectSetupDeps :: Member Trace r => GenericPackageDescription -> Sem r VersionedList diff --git a/diff/Main.hs b/diff/Main.hs --- a/diff/Main.hs +++ b/diff/Main.hs @@ -4,13 +4,14 @@ module Main (main) where +import Args import Control.Monad (unless) import qualified Data.Map as Map import Data.Text.Prettyprint.Doc.Render.Terminal import Diff -import Distribution.ArchHs.CommunityDB import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Options import Distribution.ArchHs.PP import Distribution.ArchHs.Types import GHC.IO.Encoding (setLocaleEncoding, utf8) @@ -28,14 +29,7 @@ printInfo "You assigned flags:" putDoc $ prettyFlagAssignments optFlags <> line -#ifdef ALPM - let src = if optAlpm then "libalpm" else defaultCommunityDBPath - printInfo $ "Loading community.db from" <+> pretty src - community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath -#else - printInfo $ "Loading community.db from" <+> pretty optCommunityDBPath - community <- loadCommunityDB optCommunityDBPath -#endif + community <- loadCommunityDBFromOptions optCommunityDB manager <- newTlsManager diff --git a/src/Distribution/ArchHs/Name.hs b/src/Distribution/ArchHs/Name.hs --- a/src/Distribution/ArchHs/Name.hs +++ b/src/Distribution/ArchHs/Name.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT @@ -45,6 +46,7 @@ toArchLinuxName, toHackageName, isHaskellPackage, + isGHCLibs, ) where @@ -52,6 +54,7 @@ import Data.String (IsString, fromString) import Distribution.ArchHs.Internal.NamePresetLoader import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Local import Distribution.ArchHs.Types -- | The representation of a package name. @@ -151,11 +154,21 @@ toHackageName :: HasMyName n => n -> PackageName toHackageName = mToHackageName . toHackageRep --- | Judge if a package in archlinux community repo is haskell package. +-- | Check if a package in archlinux community repo is haskell package. -- -- i.e. it is in @preset@ or has @haskell-@ prefix. -- Attention: There is no guarantee that the package exists in hackage. isHaskellPackage :: ArchLinuxName -> Bool -isHaskellPackage name = - let rep = toArchLinuxRep name - in (rep `elem` communityListP || "haskell-" `isPrefixOf` unsafeUnMyName rep) +isHaskellPackage (toArchLinuxRep -> rep) = + (rep `elem` communityListP || "haskell-" `isPrefixOf` unsafeUnMyName rep) + +-- | Check if a package is GHC or GHC Libs + +--- >>> isGHCLibs "ghc" +-- True +--- >>> isGHCLibs "text" +-- True +--- >>> isGHCLibs "arch-hs" +-- False +isGHCLibs :: PackageName -> Bool +isGHCLibs name = name == "ghc" || name `elem` ghcLibList diff --git a/src/Distribution/ArchHs/OptionReader.hs b/src/Distribution/ArchHs/OptionReader.hs deleted file mode 100644 --- a/src/Distribution/ArchHs/OptionReader.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Copyright: (c) 2020-2021 berberman --- SPDX-License-Identifier: MIT --- Maintainer: berberman --- Stability: experimental --- Portability: portable --- This module defines input patterns used in executables' cli. --- "Options.Applicative" is re-exported. -module Distribution.ArchHs.OptionReader - ( optFlagReader, - optSkippedReader, - optExtraCabalReader, - optVersionReader, - optPackageNameReader, - module Options.Applicative, - ) -where - -import qualified Data.Map.Strict as Map -import Data.Void (Void) -import Distribution.ArchHs.Internal.Prelude -import Options.Applicative -import System.FilePath (takeExtension) -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as M - -readFlag :: [(String, String, Bool)] -> Map.Map PackageName FlagAssignment -readFlag list = - Map.map toAssignment $ - foldr (\(name, fname, fvalue) acc -> Map.insertWith (<>) (mkPackageName name) [(mkFlagName fname, fvalue)] acc) Map.empty list - where - toAssignment = foldr (\(fname, fvalue) acc -> insertFlagAssignment fname fvalue acc) (mkFlagAssignment []) - --- | Read a set of package name with flag assignments. --- --- >>> f "" --- >>> f "package_name:flag_name:true" --- Right (fromList [(PackageName "package_name",fromList [(FlagName "flag_name",(1,True))])]) --- >>> f "package_name:flag_name_1:true,package_name:flag_name_2:false" --- Right (fromList [(PackageName "package_name",fromList [(FlagName "flag_name_1",(1,True)),(FlagName "flag_name_2",(1,False))])]) --- >>> f "package_name_1:flag_name_1:false,package_name_2:flag_name_2:true" --- Right (fromList [(PackageName "package_name_1",fromList [(FlagName "flag_name_1",(1,False))]),(PackageName "package_name_2",fromList [(FlagName "flag_name_2",(1,True))])]) --- >>> f "zzz" --- Left "1:4:\n |\n1 | zzz\n | ^\nunexpected end of input\nexpecting ':'\n" -optFlagReader :: ReadM (Map.Map PackageName FlagAssignment) -optFlagReader = - eitherReader - ( \s -> case M.parse optFlagParser "" s of - Right x -> Right x - Left err -> Left $ M.errorBundlePretty err - ) - -optFlagParser :: M.Parsec Void String (Map.Map PackageName FlagAssignment) -optFlagParser = - readFlag - <$> ( do - pkg <- M.manyTill M.anySingle $ M.single ':' - flg <- M.manyTill M.anySingle $ M.single ':' - b <- bool - return (pkg, flg, b) - ) - `M.sepBy` "," - where - bool = do - s <- M.string "true" <|> M.string "false" - case s of - "true" -> return True - "false" -> return False - _ -> fail $ "unknown bool: " <> s - --- | Read skipped components. --- This never fails, i.e. the return value will be 'Right'. --- >>> f "" --- Right [""] --- >>> f "component_1,component_2" --- Right ["component_1","component_2"] -optSkippedReader :: ReadM [String] -optSkippedReader = eitherReader $ Right . splitOn "," - --- | Read extra cabal files. --- --- >>> f "" --- Left "Unexpected file name: " --- >>> f "a.cabal" --- Right ["a.cabal"] --- >>> f "a.cabal,b.cabal" --- Right ["a.cabal","b.cabal"] --- >>> f "a.what,b.cabal" --- Left "Unexpected file name: a.what" -optExtraCabalReader :: ReadM [FilePath] -optExtraCabalReader = eitherReader $ \x -> - let split = splitOn "," x - check = map (\e -> if takeExtension e == ".cabal" then (e, True) else (e, False)) split - failed = map fst . filter (not . snd) $ check - successful = map fst . filter snd $ check - in if failed /= [] then Left ("Unexpected file name: " <> intercalate ", " failed) else Right successful - --- | Read a 'Version' --- This function calls 'simpleParsec'. -optVersionReader :: ReadM Version -optVersionReader = - eitherReader - ( \s -> case simpleParsec s of - Just v -> Right v - _ -> Left $ "Failed to parse version: " <> s - ) - --- | Read a 'PackageName' --- This function never fails, because it just wraps the input string with 'mkPackageName'. -optPackageNameReader :: ReadM PackageName -optPackageNameReader = eitherReader $ Right . mkPackageName diff --git a/src/Distribution/ArchHs/Options.hs b/src/Distribution/ArchHs/Options.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Options.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Copyright: (c) 2020-2021 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- This module contains CLI parsers used in executables. +-- "Options.Applicative.Simple" is re-exported. +module Distribution.ArchHs.Options + ( -- * Load Community DB + CommunityDBOptions (..), + communityDBOptionsParser, + + -- * Load files DB + FilesDBOptions (..), + filesDBOptionsParser, + + -- * Load Hackage DB + HackageDBOptions (..), + hackageDBOptionsParser, + + -- * Parse flags + optFlagAssignmentParser, + optFlagReader, + + -- * Readers + optPackageNameReader, + optVersionReader, + module Options.Applicative.Simple, + ) +where + +import qualified Data.Map.Strict as Map +import Distribution.ArchHs.CommunityDB +import Distribution.ArchHs.FilesDB +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types +import Options.Applicative.Simple + +----------------------------------------------------------------------------- + +-- | Parsed options for loading [community] +newtype CommunityDBOptions = CommunityDBOptions + { loadCommunityDBFromOptions :: IO CommunityDB + } + +-- | CLI options parser of 'CommunityDBOptions' +-- +-- When alpm is enabled, it reads a flag @no-alpm-community@; +-- otherwise it reads a string option @community@. +communityDBOptionsParser :: Parser CommunityDBOptions + +#ifndef ALPM +communityDBOptionsParser = + CommunityDBOptions + <$> fmap + ( \s -> + do + printInfo $ "Loading community.db from" <+> pretty s + loadCommunityDB s + ) + ( strOption $ + long "community" + <> metavar "PATH" + <> short 'c' + <> help "Path to community.db" + <> showDefault + <> value defaultCommunityDBPath + ) +#else +communityDBOptionsParser = + CommunityDBOptions + <$> fmap + ( \b -> + do + let src = if b then "libalpm" else defaultCommunityDBPath + printInfo $ "Loading community.db from" <+> pretty src + if b + then loadCommunityDBFFI + else loadCommunityDB defaultCommunityDBPath + ) + ( flag + True + False + ( long "no-alpm-community" + <> help "Do not use libalpm to parse community db" + ) + ) +#endif +----------------------------------------------------------------------------- + +-- | Parsed options for loading 'FilesDB' +newtype FilesDBOptions = FilesDBOptions + { loadFilesDBFromOptions :: DBKind -> IO FilesDB + } + +-- | CLI options parser of 'CommunityDBOptions' +-- +-- When alpm is enabled, it reads a flag @no-alpm-files@; +-- otherwise it reads a string option @files@. +filesDBOptionsParser :: Parser FilesDBOptions + +#ifndef ALPM +filesDBOptionsParser = + FilesDBOptions + <$> fmap + ( \s db -> + do + printInfo $ + "Loading" <+> ppDBKind db <+> "files from" <+> pretty s + loadFilesDB db s + ) + ( strOption $ + long "files" + <> metavar "PATH" + <> short 'f' + <> help + "Path of dir that includes core.files, extra.files and community.files" + <> showDefault + <> value defaultFilesDBDir + ) +#else +filesDBOptionsParser = + FilesDBOptions + <$> fmap + ( \b db -> + do + let src = if b then "libalpm" else defaultFilesDBDir + printInfo $ + "Loading" <+> ppDBKind db <+> "files from" <+> pretty src + if b then loadFilesDBFFI db else loadFilesDB db defaultFilesDBDir + ) + ( flag + True + False + ( long "no-alpm-files" + <> help "Do not use libalpm to parse files db" + ) + ) +#endif +----------------------------------------------------------------------------- + +-- | Parsed options for loading 'HackageDB' +newtype HackageDBOptions = HackageDBOptions + { loadHackageDBFromOptions :: IO HackageDB + } + +-- | CLI options parser that reads a string option @hackage@. +hackageDBOptionsParser :: Parser HackageDBOptions +hackageDBOptionsParser = + HackageDBOptions + <$> fmap + ( \s -> + do + hackagePath <- if null s then lookupHackagePath else pure s + printInfo $ "Loading hackage from" <+> pretty hackagePath + loadHackageDB hackagePath + ) + ( strOption $ + long "hackage" + <> metavar "PATH" + <> short 'h' + <> help "Path to hackage index tarball" + <> showDefault + <> value "" + ) + +----------------------------------------------------------------------------- + +-- | Read a flag assignment like @package_name:flag_name:true|false@ +optFlagReader :: ReadM (String, String, Bool) +optFlagReader = eitherReader $ \s -> case splitOn ":" s of + [name, fname, fvalue] -> case fvalue of + "true" -> Right (name, fname, True) + "false" -> Right (name, fname, False) + _ -> Left "Unknown boolean value, it should be 'true' or 'false'" + _ -> Left "Failed to parse flag assignment" + +-- | CLI options parser of flag assignments +optFlagAssignmentParser :: Parser (Map.Map PackageName FlagAssignment) +optFlagAssignmentParser = + fmap toFlagAssignment <$> many $ + option optFlagReader $ + long "flag" + <> metavar "package_name:flag_name:true|false" + <> short 'f' + <> help "A sinlge flag assignment for a package - e.g. inline-c:gsl-example:true" + +toFlagAssignment :: [(String, String, Bool)] -> Map.Map PackageName FlagAssignment +toFlagAssignment xs = + Map.map toAssignment $ + foldr (\(name, fname, fvalue) acc -> Map.insertWith (<>) (mkPackageName name) [(mkFlagName fname, fvalue)] acc) Map.empty xs + where + toAssignment = foldr (\(fname, fvalue) acc -> insertFlagAssignment fname fvalue acc) (mkFlagAssignment []) + +----------------------------------------------------------------------------- + +-- | Read a 'Version' +-- This function calls 'simpleParsec'. +optVersionReader :: ReadM Version +optVersionReader = + eitherReader + ( \s -> case simpleParsec s of + Just v -> Right v + _ -> Left $ "Failed to parse version: " <> s + ) + +-- | Read a 'PackageName' +-- This function never fails, because it just wraps the input string with 'mkPackageName'. +optPackageNameReader :: ReadM PackageName +optPackageNameReader = eitherReader $ Right . mkPackageName diff --git a/src/Distribution/ArchHs/Utils.hs b/src/Distribution/ArchHs/Utils.hs --- a/src/Distribution/ArchHs/Utils.hs +++ b/src/Distribution/ArchHs/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | Copyright: (c) 2020-2021 berberman @@ -7,7 +8,8 @@ -- Portability: portable -- Miscellaneous functions used crossing modules. module Distribution.ArchHs.Utils - ( getPkgName, + ( findCabalFile, + getPkgName, getPkgName', getPkgVersion, dependencyTypeToKind, @@ -36,6 +38,7 @@ noDiff, mapDiff, unDiff, + archHsVersion, ) where @@ -54,7 +57,23 @@ import Distribution.Types.PkgconfigName import Distribution.Utils.ShortText (fromShortText) import GHC.Stack (callStack, prettyCallStack) +import Options.Applicative.Simple (simpleVersion) +import qualified Paths_arch_hs as Path +import System.Directory (listDirectory) +import System.FilePath (takeExtension) +-- | Find a cabal file in @dir@, +-- throws error if nothing or more than one files are found +findCabalFile :: FilePath -> IO FilePath +findCabalFile dir = + listDirectory dir + >>= ( \case + [x] -> pure $ dir x + [] -> fail $ "Unable to find any cabal file in directory " <> dir + xs -> fail $ "Found more than one cabal files" <> show xs <> "in directory " <> dir + ) + . filter (\x -> takeExtension x == ".cabal") + -- | Extract the package name from a 'ExeDependency'. unExe :: ExeDependency -> PackageName unExe (ExeDependency name _ _) = name @@ -212,3 +231,7 @@ unDiff (First x) = x unDiff (Second x) = x unDiff (Both x _) = x + +-- | The version of arch-hs +archHsVersion :: String +archHsVersion = $(simpleVersion Path.version) diff --git a/submit/Main.hs b/submit/Main.hs deleted file mode 100644 --- a/submit/Main.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Main (main) where - -import Control.Monad (unless) -import Distribution.ArchHs.CommunityDB -import Distribution.ArchHs.Exception -import Distribution.ArchHs.Hackage -import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.PP -import Distribution.ArchHs.Types -import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Network.HTTP.Client (Manager) -import Network.HTTP.Client.TLS (newTlsManager) -import Submit -import System.Directory (doesFileExist) -import System.Environment (lookupEnv) - -main :: IO () -main = printHandledIOException $ - do - setLocaleEncoding utf8 - Options {..} <- runArgsParser - - token <- lookupEnv "HACKAGE_API_TOKEN" - - when (null token) $ - printWarn "You didn't set HACKAGE_API_TOKEN, dry run only." - - let hasOutput = not $ null optOutput - when hasOutput $ do - printInfo $ "Output will be dumped to" <+> pretty optOutput - exist <- doesFileExist optOutput - when exist $ - printWarn $ "File" <+> pretty optOutput <+> "already existed" <+> "overwrite it" - printInfo "Start running..." - unless (optUpload || hasOutput) $ - printWarn "Run diff and check only" - -#ifdef ALPM - let src = if optAlpm then "libalpm" else defaultCommunityDBPath - printInfo $ "Loading community.db from" <+> pretty src - community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath -#else - printInfo $ "Loading community.db from" <+> pretty optCommunityDBPath - community <- loadCommunityDB optCommunityDBPath -#endif - - hackagePath <- if null optHackagePath then lookupHackagePath else return optHackagePath - - printInfo $ "Loading hackage from" <+> pretty hackagePath - - hackage <- loadHackageDB hackagePath - - manager <- newTlsManager - - runSubmit community hackage manager (submit token optOutput optUpload) & printAppResult - -runSubmit :: - CommunityDB -> - HackageDB -> - Manager -> - Sem '[CommunityEnv, HackageEnv, Reader Manager, WithMyErr, Embed IO, Final IO] a -> - IO (Either MyException a) -runSubmit community hackage manager = - runFinal - . embedToFinal - . errorToIOFinal - . runReader manager - . runReader hackage - . runReader community diff --git a/submit/Submit.hs b/submit/Submit.hs deleted file mode 100644 --- a/submit/Submit.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Submit - ( Options (..), - runArgsParser, - submit, - ) -where - -import Control.Monad (unless) -import Data.Algorithm.Diff (getGroupedDiff) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Void (Void) -import Distribution.ArchHs.Exception -import Distribution.ArchHs.Hackage -import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.Local -import Distribution.ArchHs.Name -import Distribution.ArchHs.PP -import Distribution.ArchHs.Types -import Distribution.ArchHs.Utils (filterFirstDiff, filterSecondDiff, mapDiff, noDiff) -import Network.HTTP.Client -import Options.Applicative hiding (header) -import qualified Options.Applicative -import qualified Text.Megaparsec as M -import Text.Megaparsec.Char as M - -#ifndef ALPM -import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) -#endif - -data Options = Options - { optHackagePath :: FilePath, -#ifndef ALPM - optCommunityDBPath :: FilePath, -#else - optAlpm :: Bool, -#endif - optOutput :: FilePath, - optUpload :: Bool - } - -cmdOptions :: Parser Options -cmdOptions = - Options - <$> strOption - ( long "hackage" - <> metavar "PATH" - <> short 'h' - <> help "Path to hackage index tarball" - <> showDefault - <> value "" - ) -#ifndef ALPM - <*> strOption - ( long "community" - <> metavar "PATH" - <> short 'c' - <> help "Path to community.db" - <> showDefault - <> value defaultCommunityDBPath - ) -#else - <*> switch - ( long "alpm" - <> help "Use libalpm to parse community db" - ) -#endif - <*> Options.Applicative.option - str - ( long "output" - <> metavar "PATH" - <> short 'o' - <> help "Output path of generated .csv file" - <> value "" - ) - <*> switch - ( long "upload" - <> short 'u' - <> help "Upload to hackage" - ) - -runArgsParser :: IO Options -runArgsParser = - execParser $ - info - (cmdOptions <**> helper) - ( fullDesc - <> progDesc "Try to reach the TARGET QAQ." - <> Options.Applicative.header "arch-hs-submit - a program submitting haskell packages in community to hackage arch distro." - ) - -type DistroRecord = (String, String, String) - -type DistroCSV = [DistroRecord] - -renderDistroCSV :: DistroCSV -> String -renderDistroCSV = init . unlines . fmap (\(a, b, c) -> wrap a <> "," <> wrap b <> "," <> wrap c) - where - wrap x = "\"" <> x <> "\"" - -distroCSVParser :: M.Parsec Void String DistroCSV -distroCSVParser = M.sepBy distroRecordParser newline - -distroRecordParser :: M.Parsec Void String DistroRecord -distroRecordParser = - (M.between (M.char '"') (M.char '"') (M.many $ M.noneOf (",\"\n" :: String)) `M.sepBy` M.char ',') >>= \case - [a, b, c] -> return (a, b, c) - _ -> fail "Failed to parse record" - -parseDistroCSV :: String -> DistroCSV -parseDistroCSV s = case M.parse distroCSVParser "DistroCSV" s of - Left err -> fail $ M.errorBundlePretty err - Right x -> x - -genCSV :: Members [CommunityEnv, HackageEnv, Embed IO] r => Sem r DistroCSV -genCSV = do - communityDb <- ask @CommunityDB - notLinked <- getAndPrintNotLinked - - let communityPackages = Map.toList communityDb - inHackage = (`notElem` notLinked) - fields = - communityPackages - ^.. each - . filtered (((&&) <$> inHackage <*> isHaskellPackage) . (^. _1)) - <&> (_1 <<%~ toHackageName) - & sortBy (\x y -> (x ^. _2 . _1) `compare` (y ^. _2 . _1)) - prefix = "https://www.archlinux.org/packages/community/x86_64/" - processField (archLinuxName, (hackageName, version)) = - let archLinuxName' = - if hackageName `elem` ghcLibList || hackageName == "ghc" - then "ghc" - else unArchLinuxName archLinuxName - in (unPackageName hackageName, version, prefix <> archLinuxName') - return $ processField <$> fields - -submit :: Members [HackageEnv, CommunityEnv, WithMyErr, Reader Manager, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r () -submit token output upload = do - csv <- genCSV - let v = renderDistroCSV csv - embed $ - unless (null output) $ do - printInfo $ "Write file" <> colon <+> pretty output - writeFile output v - check csv - manager <- ask - interceptHttpException $ - when ((not . null) token && upload) $ do - printInfo "Uploading..." - initialRequest <- parseRequest "https://hackage.haskell.org/distro/Arch/packages" - let req = - initialRequest - { method = "PUT", - requestBody = RequestBodyBS . BS.pack $ v, - requestHeaders = - [ ("Authorization", "X-ApiKey " <> BS.pack (fromJust token)), - ("Content-Type", "text/csv") - ] - } - result <- httpLbs req manager - printInfo $ "Status" <> colon <+> viaShow (responseStatus result) - printInfo "ResponseBody:" - printInfo . pretty . decodeUtf8 . LBS.toStrict $ responseBody result - -check :: Members [HackageEnv, WithMyErr, Reader Manager, Embed IO] r => DistroCSV -> Sem r () -check community = do - printInfo "Checking generated csv file..." - - req <- interceptHttpException $ parseRequest "https://hackage.haskell.org/distro/Arch/packages.csv" - printInfo "Downloading csv from hackage..." - manager <- ask - result <- interceptHttpException $ httpLbs req manager - let bs = responseBody result - hackage = parseDistroCSV . T.unpack . decodeUtf8 . LBS.toStrict $ bs - - let diff = getGroupedDiff hackage community - diffOld = filterFirstDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord)) - diffNew = filterSecondDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord)) - ppRecord (name, version, url) = "(" <> name <> ", " <> version <> ", " <> url <> ")" - j g x = if null x then "[]" else g x - embed . putDoc . annMagneta $ "Diff" <> colon <> line - embed . putDoc . indent 2 $ - if noDiff diff - then "[]" - else - j cat diffOld - <> splitLine - <> j cat diffNew - <> line - - embed . putDoc $ - "Found" - <+> pretty (length hackage) - <+> "packages with submitted distribution information in hackage, and" - <+> pretty (length community) - <+> "haskell packages in" - <+> ppCommunity - <> dot - <> line - -getAndPrintNotLinked :: Members [CommunityEnv, HackageEnv, Embed IO] r => Sem r [ArchLinuxName] -getAndPrintNotLinked = do - communityHaskellPackages <- filter isHaskellPackage . Map.keys <$> ask @CommunityDB - hackagePackages <- Map.keys <$> ask @HackageDB - let result = filter (\x -> toHackageName x `notElem` hackagePackages) communityHaskellPackages - - unless (null result) $ - printWarn $ "Following packages in" <+> ppCommunity <+> "are not linked to hackage:" - - embed . putStr . unlines $ unArchLinuxName <$> result - return result diff --git a/sync/Args.hs b/sync/Args.hs new file mode 100644 --- /dev/null +++ b/sync/Args.hs @@ -0,0 +1,81 @@ +module Args + ( CommonOptions (..), + SubmitOptions (..), + CheckOptions (..), + Mode (..), + runArgsParser, + ) +where + +import Distribution.ArchHs.Options +import Distribution.ArchHs.Utils (archHsVersion) + +----------------------------------------------------------------------------- + +data CommonOptions = CommonOptions + { optHackage :: HackageDBOptions, + optCommunityDB :: CommunityDBOptions + } + +commonOptionsParser :: Parser CommonOptions +commonOptionsParser = + CommonOptions <$> hackageDBOptionsParser <*> communityDBOptionsParser + +----------------------------------------------------------------------------- + +data SubmitOptions = SubmitOptions + { optOutput :: FilePath, + optUpload :: Bool + } + +submitOptionsParser :: Parser SubmitOptions +submitOptionsParser = + SubmitOptions + <$> option + str + ( long "output" + <> metavar "PATH" + <> short 'o' + <> help "Output path of generated .csv file" + <> value "" + ) + <*> switch + ( long "upload" + <> short 'u' + <> help "Upload to hackage" + ) + +----------------------------------------------------------------------------- + +newtype CheckOptions = CheckOptions + { optShowGHCLibs :: Bool + } + +checkOptionsParser :: Parser CheckOptions +checkOptionsParser = + CheckOptions + <$> switch (long "show-ghc-libs" <> help "Include GHC and GHC libs") + +----------------------------------------------------------------------------- + +data Mode = Submit CommonOptions SubmitOptions | Check CommonOptions CheckOptions + +runArgsParser :: IO Mode +runArgsParser = + snd <$> do + simpleOptions + archHsVersion + "arch-hs-sync - sync metadata of Haskell packages between [community] and Hackage" + "arch-hs-sync is designed to be used by Hackage distribution maintainers" + (pure ()) + $ do + addCommand + "submit" + "submit distribution information to Hackage" + id + (Submit <$> commonOptionsParser <*> submitOptionsParser) + addCommand + "check" + "check inconsistencies of Haskell packages version" + id + (Check <$> commonOptionsParser <*> checkOptionsParser) diff --git a/sync/Check.hs b/sync/Check.hs new file mode 100644 --- /dev/null +++ b/sync/Check.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Check (check) where + +import Data.Maybe (maybeToList) +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name (isGHCLibs) +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types +import Distribution.Package (packageName, packageVersion) +import Utils + +check :: Members [HackageEnv, CommunityEnv, WithMyErr, Embed IO] r => Bool -> Sem r () +check includeGHC = do + linked <- linkedHaskellPackages + let result = + [ annMagneta (pretty (unArchLinuxName archName)) + <+> "in" + <+> ppCommunity + <+> "has version" + <+> (if isHackageNewer then annRed else annGreen) (viaPretty archVersion) + <> comma + <+> "but linked" + <+> annMagneta (pretty (unPackageName hackageName)) + <+> "in" + <+> annCyan "Hackage" + <+> "has" + <+> (if isHackageNewer then "a newer" else "an older") + <+> "version" + <+> (if isHackageNewer then annGreen else annRed) (viaPretty hackageVersion) + | (archName, rawArchVersion, cabal) <- linked, + let hackageName = packageName cabal + hackageVersion = packageVersion cabal, + archVersion <- maybeToList $ simpleParsec rawArchVersion, + includeGHC || not (isGHCLibs hackageName), + archVersion /= hackageVersion, + let isHackageNewer = hackageVersion > archVersion + ] + if (null result) + then printSuccess "Finished checking" + else do + printWarn $ "Finished checking with inconsistenc(ies):" + embed $ putDoc $ vcat result <> line diff --git a/sync/Main.hs b/sync/Main.hs new file mode 100644 --- /dev/null +++ b/sync/Main.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import Args +import Check +import Control.Monad (unless) +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Options +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types +import Network.HTTP.Client +import Network.HTTP.Client.TLS (newTlsManager) +import Submit +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) + +main :: IO () +main = runArgsParser >>= runMode + +runCheck :: + CommunityDB -> + HackageDB -> + Bool -> + IO (Either MyException ()) +runCheck community hackage includeGHC= + ( runFinal + . embedToFinal @IO + . errorToIOFinal + . runReader hackage + . runReader community + ) + (check includeGHC) + +runSubmit :: + CommunityDB -> + HackageDB -> + Manager -> + Maybe String -> + FilePath -> + Bool -> + IO (Either MyException ()) +runSubmit community hackage manager token output upload = + ( runFinal + . embedToFinal @IO + . errorToIOFinal + . runReader manager + . runReader hackage + . runReader community + ) + (submit token output upload) + +runMode :: Mode -> IO () +runMode = \case + Submit CommonOptions {..} SubmitOptions {..} -> do + community <- loadCommunityDBFromOptions optCommunityDB + hackage <- loadHackageDBFromOptions optHackage + + token <- lookupEnv "HACKAGE_API_TOKEN" + + when (null token) $ + printWarn "You didn't set HACKAGE_API_TOKEN, dry run only." + + let hasOutput = not $ null optOutput + when hasOutput $ do + printInfo $ "Output will be dumped to" <+> pretty optOutput + exist <- doesFileExist optOutput + when exist $ + printWarn $ "File" <+> pretty optOutput <+> "already existed" <+> "overwrite it" + + printInfo "Start running..." + unless (optUpload || hasOutput) $ + printWarn "Run diff and check only" + + manager <- newTlsManager + runSubmit community hackage manager token optOutput optUpload & printAppResult + Check CommonOptions {..} CheckOptions {..} -> do + community <- loadCommunityDBFromOptions optCommunityDB + hackage <- loadHackageDBFromOptions optHackage + runCheck community hackage optShowGHCLibs & printAppResult diff --git a/sync/Submit.hs b/sync/Submit.hs new file mode 100644 --- /dev/null +++ b/sync/Submit.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Submit (submit) where + +import Control.Monad (unless) +import Data.Algorithm.Diff (getGroupedDiff) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import Data.List (sortOn) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name (isGHCLibs) +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.Package (packageName) +import Network.HTTP.Client +import Submit.CSV +import Utils + +-- | Generate Distro CSV from Community DB +genCSV :: Members [CommunityEnv, HackageEnv, WithMyErr, Embed IO] r => Sem r DistroCSV +genCSV = do + linked <- linkedHaskellPackages + pure $ + sortOn + (\x -> x ^. _1) + [ (unPackageName hackageName, version, prefix <> tweakedName) + | (archLinuxName, version, packageName -> hackageName) <- linked, + let tweakedName = + if isGHCLibs hackageName + then "ghc" + else unArchLinuxName archLinuxName + prefix = "https://www.archlinux.org/packages/community/x86_64/" + ] + +-- | Check and submit distro CSV to Hackage +submit :: Members [HackageEnv, CommunityEnv, WithMyErr, Reader Manager, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r () +submit token output upload = do + csv <- genCSV + let v = renderDistroCSV csv + embed $ + unless (null output) $ do + printInfo $ "Write file" <> colon <+> pretty output + writeFile output v + check csv + manager <- ask + interceptHttpException $ + when ((not . null) token && upload) $ do + printInfo "Uploading..." + initialRequest <- parseRequest "https://hackage.haskell.org/distro/Arch/packages" + let req = + initialRequest + { method = "PUT", + requestBody = RequestBodyBS . BS.pack $ v, + requestHeaders = + [ ("Authorization", "X-ApiKey " <> BS.pack (fromJust token)), + ("Content-Type", "text/csv") + ] + } + result <- httpLbs req manager + printInfo $ "Status" <> colon <+> viaShow (responseStatus result) + printInfo "ResponseBody:" + printInfo . pretty . decodeUtf8 . LBS.toStrict $ responseBody result + +-- | Download Distro CSV from Hackage and print differences from @community@ +check :: Members [HackageEnv, WithMyErr, Reader Manager, Embed IO] r => DistroCSV -> Sem r () +check community = do + printInfo "Checking generated csv file..." + + req <- interceptHttpException $ parseRequest "https://hackage.haskell.org/distro/Arch/packages.csv" + printInfo "Downloading csv from hackage..." + manager <- ask + result <- interceptHttpException $ httpLbs req manager + let bs = responseBody result + hackage = parseDistroCSV . T.unpack . decodeUtf8 . LBS.toStrict $ bs + + let diff = getGroupedDiff hackage community + diffOld = filterFirstDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord)) + diffNew = filterSecondDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord)) + ppRecord (name, version, url) = "(" <> name <> ", " <> version <> ", " <> url <> ")" + j g x = if null x then "[]" else g x + embed . putDoc . annMagneta $ "Diff" <> colon <> line + embed . putDoc . indent 2 $ + if noDiff diff + then "[]" + else + j cat diffOld + <> splitLine + <> j cat diffNew + <> line + + embed . putDoc $ + "Found" + <+> pretty (length hackage) + <+> "packages with submitted distribution information in hackage, and" + <+> pretty (length community) + <+> "haskell packages in" + <+> ppCommunity + <> dot + <> line diff --git a/sync/Submit/CSV.hs b/sync/Submit/CSV.hs new file mode 100644 --- /dev/null +++ b/sync/Submit/CSV.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Submit.CSV + ( DistroRecord, + DistroCSV, + renderDistroCSV, + parseDistroCSV, + ) +where + +import Data.Void (Void) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as M + +type DistroRecord = (String, String, String) + +type DistroCSV = [DistroRecord] + +renderDistroCSV :: DistroCSV -> String +renderDistroCSV = init . unlines . fmap (\(a, b, c) -> wrap a <> "," <> wrap b <> "," <> wrap c) + where + wrap x = "\"" <> x <> "\"" + +distroCSVParser :: M.Parsec Void String DistroCSV +distroCSVParser = M.sepBy distroRecordParser M.newline + +distroRecordParser :: M.Parsec Void String DistroRecord +distroRecordParser = + (M.between (M.char '"') (M.char '"') (M.many $ M.noneOf (",\"\n" :: String)) `M.sepBy` M.char ',') >>= \case + [a, b, c] -> return (a, b, c) + _ -> fail "Failed to parse record" + +parseDistroCSV :: String -> DistroCSV +parseDistroCSV s = case M.parse distroCSVParser "DistroCSV" s of + Left err -> fail $ M.errorBundlePretty err + Right x -> x diff --git a/sync/Utils.hs b/sync/Utils.hs new file mode 100644 --- /dev/null +++ b/sync/Utils.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Utils + ( linkedHaskellPackages, + ) +where + +import Control.Monad (unless) +import qualified Data.Map.Strict as Map +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types + +linkedHaskellPackages :: + Members [CommunityEnv, HackageEnv, WithMyErr, Embed IO] r => + Sem r ([(ArchLinuxName, ArchLinuxVersion, GenericPackageDescription)]) +linkedHaskellPackages = do + communityHaskellPackages <- filter (isHaskellPackage . fst) . Map.toList <$> ask @CommunityDB + hackagePackages <- Map.keys <$> ask @HackageDB + let go xs ys ((name, version) : pkgs) = + let hName = toHackageName name + in if hName `elem` hackagePackages + then getLatestCabal hName >>= \cabal -> go ((name, version, cabal) : xs) ys pkgs + else go xs (name : ys) pkgs + go xs ys [] = pure (xs, ys) + (linked, unlinked) <- go [] [] communityHaskellPackages + embed $ + unless (null unlinked) $ do + printWarn $ "Following packages in" <+> ppCommunity <+> "are not linked to hackage:" + putStrLn . unlines $ unArchLinuxName <$> unlinked + pure linked