diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,18 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.7.0.0 + +* Support dumping output of `arch-hs` to JSON + +* Support resolving setup dependencies in `arch-hs-diff` + +* Fix wrong concatenation direction of differentiating dependencies in `arch-hs-diff` + +* Replace `req` with [`arch-web`](https://github.com/berberman/arch-web) and `http-client` + +* Make `getLatestSHA256` become total function + ## 0.6.2.0 * Use `Doc` to print prompt messages diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,13 @@ # arch-hs [![Hackage](https://img.shields.io/hackage/v/arch-hs.svg?logo=haskell)](https://hackage.haskell.org/package/arch-hs) +![Dependency](https://img.shields.io/hackage-deps/v/arch-hs) [![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) -| Env | CI | -| ---------------- | ------------------------------------------------------------ | +| Env | CI | +| ---------------- | ------------------------------------------------------------------------------------------------------------------------- | | pacman (-f alpm) | [![GitHub CI](https://github.com/berberman/arch-hs/workflows/CI/badge.svg)](https://github.com/berberman/arch-hs/actions) | -| cabal-install | [![Build Status](https://travis-ci.com/berberman/arch-hs.svg?branch=master)](https://travis-ci.com/berberman/arch-hs) | +| cabal-install | [![Build Status](https://travis-ci.com/berberman/arch-hs.svg?branch=master)](https://travis-ci.com/berberman/arch-hs) | A program generating PKGBUILD for hackage packages. Special thanks to [felixonmars](https://github.com/felixonmars/). @@ -72,9 +73,6 @@ ## Usage -**Please ignore `hsc2hs`. This package may emerge unexpectedly, since it is missing in provide list of `ghc`.** -**This will be fixed in next GHC release by haskell maintainers of Arch Linux.** - Just run `arch-hs` in command line with options and a target. Here is an example: we will create the archlinux package of [gi-gdk](https://hackage.haskell.org/package/gi-gdk). @@ -88,299 +86,288 @@ ⓘ Loading hackage from /home/berberman/.cabal/packages/hackage.haskell.org/01-index.tar ⓘ Loading community.db from libalpm ⓘ Start running... -⚠ Package "code-page" is provided without: -hsc2hs -⚠ Package "haskell-gi" is provided without: -hsc2hs -⚠ Package "haskell-gi-base" is provided without: -hsc2hs -⚠ Package "network" is provided without: -hsc2hs -⚠ Package "terminal-size" is provided without: -hsc2hs ⓘ 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] - ├─containers [Lib] ✔ [community] - ├─gi-cairo [Lib,Setup] ✔ [community] - ├─gi-gdkpixbuf [Lib,Setup] ✘ - ├─gi-gio [Lib,Setup] ✘ - ├─gi-glib [Lib,Setup] ✘ - ├─gi-gobject [Lib,Setup] ✘ - ├─gi-pango [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-gdkpixbuf ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─gi-gio [Lib,Setup] ✘ - ├─gi-glib [Lib,Setup] ✘ - ├─gi-gobject [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-gio ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─gi-glib [Lib,Setup] ✘ - ├─gi-gobject [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-glib ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-gobject ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─gi-glib [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-harfbuzz ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─gi-glib [Lib,Setup] ✘ - ├─gi-gobject [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─haskell-gi-overloading [Lib] ✔ [community] - ├─text [Lib] ✔ [community] - └─transformers [Lib] ✔ [community] -gi-pango ✘ - ├─Cabal [Setup] ✔ [community] - ├─bytestring [Lib] ✔ [community] - ├─containers [Lib] ✔ [community] - ├─gi-glib [Lib,Setup] ✘ - ├─gi-gobject [Lib,Setup] ✘ - ├─gi-harfbuzz [Lib,Setup] ✘ - ├─haskell-gi [Lib,Setup] ✔ [community] - ├─haskell-gi-base [Lib] ✔ [community] - ├─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 ✘ -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] +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] + ├─containers (Lib) ✔ [community] + ├─gi-cairo (Lib, Setup) ✔ [community] + ├─gi-gdkpixbuf (Lib, Setup) ✘ + ├─gi-gio (Lib, Setup) ✘ + ├─gi-glib (Lib, Setup) ✘ + ├─gi-gobject (Lib, Setup) ✘ + ├─gi-pango (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-gdkpixbuf ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─gi-gio (Lib, Setup) ✘ + ├─gi-glib (Lib, Setup) ✘ + ├─gi-gobject (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-gio ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─gi-glib (Lib, Setup) ✘ + ├─gi-gobject (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-glib ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-gobject ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─gi-glib (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-harfbuzz ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─gi-glib (Lib, Setup) ✘ + ├─gi-gobject (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─haskell-gi-overloading (Lib) ✔ [community] + ├─text (Lib) ✔ [community] + └─transformers (Lib) ✔ [community] +gi-pango ✘ + ├─Cabal (Setup) ✔ [community] + ├─bytestring (Lib) ✔ [community] + ├─containers (Lib) ✔ [community] + ├─gi-glib (Lib, Setup) ✘ + ├─gi-gobject (Lib, Setup) ✘ + ├─gi-harfbuzz (Lib, Setup) ✘ + ├─haskell-gi (Lib, Setup) ✔ [community] + ├─haskell-gi-base (Lib) ✔ [community] + ├─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. hsc2hs -2. gi-glib -3. gi-gobject -4. gi-harfbuzz -5. gi-pango -6. gi-gio -7. gi-gdkpixbuf -8. gi-gdk +1. gi-glib +2. gi-gobject +3. gi-harfbuzz +4. gi-pango +5. gi-gio +6. gi-gdkpixbuf +7. gi-gdk ⓘ Detected pkgconfig or extraLib from target(s): gi-gdk: gtk4.pc @@ -392,27 +379,17 @@ gi-pango: pango.pc ⓘ Now finding corresponding system package(s) using files db: -ⓘ Loading core files from libalpm... -ⓘ Loading extra files from libalpm... -ⓘ Loading community files from libalpm... +ⓘ Loading [core] files from libalpm +ⓘ Loading [extra] files from libalpm ⓘ Done: -gtk4.pc ✘ -gdk-pixbuf-2.0.pc ⇒ gdk-pixbuf2 -gio-2.0.pc ⇒ glib2 -glib-2.0.pc ⇒ glib2 -gobject-2.0.pc ⇒ glib2 -harfbuzz.pc ⇒ harfbuzz -harfbuzz-gobject.pc ⇒ harfbuzz -pango.pc ⇒ pango - -⚠ Unable to obtain all required system packages -ⓘ Detected flag(s) from targets: -hsc2hs - ⚐ in-ghc-tree: - description: - Are we in a GHC tree? - default: False - isManual: True +gtk4.pc ⇒ gtk4 +gdk-pixbuf-2.0.pc ⇒ gdk-pixbuf2 +gio-2.0.pc ⇒ glib2 +glib-2.0.pc ⇒ glib2 +gobject-2.0.pc ⇒ glib2 +harfbuzz.pc ⇒ harfbuzz +harfbuzz-gobject.pc ⇒ harfbuzz +pango.pc ⇒ pango ⓘ Write file: /home/berberman/test/haskell-gi-gdk/PKGBUILD ⓘ Write file: /home/berberman/test/haskell-gi-gdkpixbuf/PKGBUILD @@ -421,7 +398,6 @@ ⓘ Write file: /home/berberman/test/haskell-gi-gobject/PKGBUILD ⓘ Write file: /home/berberman/test/haskell-gi-harfbuzz/PKGBUILD ⓘ Write file: /home/berberman/test/haskell-gi-pango/PKGBUILD -ⓘ Write file: /home/berberman/test/haskell-hsc2hs/PKGBUILD ✔ Success! ``` @@ -445,9 +421,7 @@ │ └── PKGBUILD ├── haskell-gi-harfbuzz │ └── PKGBUILD -├── haskell-gi-pango -│ └── PKGBUILD -└── haskell-hsc2hs +└── haskell-gi-pango └── PKGBUILD ``` @@ -594,6 +568,19 @@ ``` With `--force`, `arch-hs` will try to package even if the target is provided. + +### Json + +``` +$ arch-hs --json ./output.json TARGET +``` + +With `--json`, `arch-hs` will dump information presented in stdout to file as JSON format, including: + * abnormal dependencies + * solved packages + * recommended package order + * system dependencies + * flags ## [Name preset](https://github.com/berberman/arch-hs/blob/master/data/NAME_PRESET.json) diff --git a/app/Args.hs b/app/Args.hs --- a/app/Args.hs +++ b/app/Args.hs @@ -34,6 +34,7 @@ optUusi :: Bool, optForce :: Bool, optMetaDir :: FilePath, + optJson :: FilePath, #ifdef ALPM optAlpm :: Bool, #endif @@ -128,6 +129,12 @@ ( long "meta" <> metavar "PATH" <> help "Path to target meta package" + <> value "" + ) + <*> strOption + ( long "json" + <> metavar "PATH" + <> help "Path to json output (empty means do not write output as json to file)" <> value "" ) #ifdef ALPM diff --git a/app/Json.hs b/app/Json.hs new file mode 100644 --- /dev/null +++ b/app/Json.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Json + ( AbnormalDependencyS (..), + SolvedDependencyS (..), + SolvedPackageS (..), + SysDepsS (..), + ArchHSOutput (..), + fromAbnormalDependency, + fromSolvedDependency, + fromSolvedPackage, + fromFlag, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T +import Distribution.ArchHs.FilesDB +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Types + +packageName :: PackageName -> Value +packageName (unPackageName -> name) = String $ T.pack name + +archLinuxName :: ArchLinuxName -> Value +archLinuxName (ArchLinuxName name) = String $ T.pack name + +flag :: Flag -> Value +flag f = + object + [ "name" .= unFlagName (flagName f), + "description" .= flagDescription f, + "default" .= flagDefault f, + "manual" .= flagManual f + ] + +toValueViaShow :: (Show a) => a -> Value +toValueViaShow = String . T.pack . show + +data AbnormalDependencyS = AbnormalDependencyS + { abPkgName :: PackageName, + abDeps :: [PackageName] + } + +instance ToJSON AbnormalDependencyS where + toJSON AbnormalDependencyS {..} = + object + [ "pkg" .= packageName abPkgName, + "dep" .= listValue packageName abDeps + ] + +data SolvedDependencyS = SolvedDependencyS + { sdPkgName :: PackageName, + sdDepType :: [DependencyType], + sdProvider :: Maybe DependencyProvider + } + +instance ToJSON SolvedDependencyS where + toJSON SolvedDependencyS {..} = + object + [ "pkg" .= packageName sdPkgName, + "dep_type" .= listValue toValueViaShow sdDepType, + "provider" .= maybe Null toValueViaShow sdProvider + ] + +data SolvedPackageS = SolvedPackageS + { spPkgName :: PackageName, + spDeps :: [SolvedDependencyS], + spProvider :: Maybe DependencyProvider + } + +instance ToJSON SolvedPackageS where + toJSON SolvedPackageS {..} = + object $ + [ "pkg" .= packageName spPkgName, + "provider" .= maybe Null toValueViaShow spProvider + ] + ++ ["dep" .= listValue toJSON spDeps | null spProvider] + +data SysDepsS = SysDepsS + { ssFile :: File, + ssArchPkg :: Maybe ArchLinuxName + } + +instance ToJSON SysDepsS where + toJSON SysDepsS {..} = + object + [ "file" .= ssFile, + "arch_pkg" .= case ssArchPkg of + Just x -> archLinuxName x + _ -> Null + ] + +data FlagsS = FlagsS + { fPkg :: PackageName, + fFlag :: [Flag] + } + +instance ToJSON FlagsS where + toJSON FlagsS {..} = + object + [ "pkg" .= packageName fPkg, + "flag" .= listValue flag fFlag + ] + +data ArchHSOutput = ArchHSOutput + { abnormal :: [AbnormalDependencyS], + solved :: [SolvedPackageS], + order :: [PackageName], + sys :: [SysDepsS], + flags :: [FlagsS] + } + +instance ToJSON ArchHSOutput where + toJSON ArchHSOutput {..} = + object + [ "abnormal_dep" .= listValue toJSON abnormal, + "solved_pkg" .= listValue toJSON solved, + "recommended_order" .= listValue packageName order, + "system_dep" .= listValue toJSON sys, + "flags" .= listValue toJSON flags + ] + +fromAbnormalDependency :: (PackageName, [PackageName]) -> AbnormalDependencyS +fromAbnormalDependency (abPkgName, abDeps) = AbnormalDependencyS {..} + +fromSolvedDependency :: SolvedDependency -> SolvedDependencyS +fromSolvedDependency SolvedDependency {..} = SolvedDependencyS _depName _depType _depProvider + +fromSolvedPackage :: SolvedPackage -> SolvedPackageS +fromSolvedPackage ProvidedPackage {..} = SolvedPackageS _pkgName [] (Just _pkgProvider) +fromSolvedPackage SolvedPackage {..} = SolvedPackageS _pkgName (fromSolvedDependency <$> _pkgDeps) Nothing + +fromFlag :: (PackageName, [Flag]) -> FlagsS +fromFlag (fPkg, fFlag) = FlagsS {..} diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,6 +11,8 @@ import qualified Algebra.Graph.Labelled.AdjacencyMap as GL import Args import Control.Monad (filterM, forM_, unless) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as LBS import Data.Containers.ListUtils (nubOrd) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.List.NonEmpty (toList) @@ -32,6 +34,9 @@ import qualified Distribution.ArchHs.PkgBuild as N import Distribution.ArchHs.Types import Distribution.ArchHs.Utils +import Json +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeFileName) @@ -44,9 +49,10 @@ Bool -> Bool -> FilePath -> + FilePath -> (DBKind -> IO FilesDB) -> Sem r () -app target path aurSupport skip uusi force metaPath loadFilesDB' = do +app target path aurSupport skip uusi force metaPath jsonPath loadFilesDB' = do (deps, sublibs, sysDeps) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target inCommunity <- isInCommunity target @@ -80,9 +86,9 @@ providedPackages embed $ - forM_ abnormalDependencies $ \(T.pack . unPackageName -> parent, childs) -> do + forM_ abnormalDependencies $ \(T.pack . unPackageName -> parent, children) -> do printWarn $ "Package" <+> dquotes (pretty parent) <+> "is provided without" <> colon - forM_ childs $ putStrLn . unPackageName + forM_ children $ putStrLn . unPackageName let fillProvidedPkgs provideList provider = map (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x) fillProvidedDeps provideList provider = map (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider ?~ provider else y)) @@ -153,6 +159,19 @@ printInfo "Detected flag(s) from targets:" putDoc $ prettyFlags flags <> line <> line + let jsonOutput = + ArchHSOutput + (fromAbnormalDependency <$> abnormalDependencies) + (fromSolvedPackage <$> filledByBoth) + (reverse flattened) + (fromEmergedSysDep <$> sysDepsResult) + (fromFlag <$> flags) + + embed $ + unless (null jsonPath) $ do + LBS.writeFile jsonPath $ A.encode jsonOutput + printInfo $ "Write file" <> colon <+> pretty jsonPath + unless (null path) $ mapM_ ( \solved -> do @@ -221,6 +240,10 @@ ppEmergedSysDep (Solved file (ArchLinuxName name)) = (annGreen . pretty $ file, " ⇒ " <> (annCyan . pretty $ name)) ppEmergedSysDep (Unsolved file) = (annYellow . annBold . pretty $ file, indent 19 cuo) +fromEmergedSysDep :: EmergedSysDep -> SysDepsS +fromEmergedSysDep (Unsolved file) = SysDepsS file Nothing +fromEmergedSysDep (Solved file pkg) = SysDepsS file (Just pkg) + ----------------------------------------------------------------------------- runApp :: @@ -230,13 +253,14 @@ Bool -> FilePath -> IORef (Set.Set PackageName) -> + Manager -> Sem '[CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, State (Set.Set PackageName), Aur, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) -runApp hackage community flags traceStdout tracePath ref = +runApp hackage community flags traceStdout tracePath ref manager = runFinal . embedToFinal . errorToIOFinal - . aurToIO + . aurToIO manager . runStateIORef ref . runTrace traceStdout tracePath . evalState Map.empty @@ -261,6 +285,10 @@ printInfo $ "Trace will be dumped to" <+> pretty optFileTrace writeFile optFileTrace "" + unless (null optJson) $ do + printInfo $ "Output will be dumped to" <+> pretty optJson <+> "as json" + writeFile optJson "" + let isFlagEmpty = Map.null optFlags isSkipEmpty = null optSkip @@ -314,7 +342,18 @@ #endif - runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir loadF) & printAppResult + manager <- newTlsManager + + runApp + newHackage + community + optFlags + optStdoutTrace + optFileTrace + empty + manager + (app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir optJson loadF) + & 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.6.2.0 +version: 0.7.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -15,7 +15,7 @@ license-file: LICENSE author: berberman maintainer: berberman -copyright: 2020 berberman +copyright: (c) 2020-2021 berberman category: Distribution build-type: Simple extra-source-files: data/NAME_PRESET.json @@ -38,17 +38,20 @@ build-depends: , aeson ^>=1.5.4 , algebraic-graphs ^>=0.5 - , base ^>=4.14.0 - , bytestring ^>=0.10.10 + , arch-web ^>=0.1.0 + , base >=4.12 && <5 + , bytestring , Cabal ^>=3.2.0 , conduit ^>=1.3.2 , conduit-extra ^>=1.3.5 - , containers ^>=0.6.2 + , containers , deepseq ^>=1.4.4 , Diff ^>=0.4.0 , directory ^>=1.3.6 , filepath ^>=1.4.2 , hackage-db ^>=2.1.0 + , http-client + , http-client-tls , megaparsec ^>=9.0.0 , microlens ^>=0.4.11 , microlens-th ^>=0.4.3 @@ -57,11 +60,11 @@ , polysemy , prettyprinter ^>=1.7.0 , prettyprinter-ansi-terminal ^>=1.1.2 - , req ^>=3.8.0 + , servant-client ^>=0.18.2 , split ^>=0.2.3 , tar-conduit ^>=0.3.2 , template-haskell ^>=2.16.0 - , text ^>=1.2.3 + , text ghc-options: -Wall -Wcompat -Widentities -Wincomplete-uni-patterns @@ -109,15 +112,16 @@ Distribution.ArchHs.Types Distribution.ArchHs.Utils - other-modules: - Data.Aeson.Ext - Distribution.ArchHs.Internal.NamePresetLoader + other-modules: Distribution.ArchHs.Internal.NamePresetLoader executable arch-hs import: common-options hs-source-dirs: app main-is: Main.hs - other-modules: Args + other-modules: + Args + Json + build-depends: arch-hs ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/diff/Diff.hs b/diff/Diff.hs --- a/diff/Diff.hs +++ b/diff/Diff.hs @@ -10,9 +10,9 @@ where import Data.Algorithm.Diff +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 Distribution.ArchHs.CommunityDB (versionInCommunity) import Distribution.ArchHs.Core (evalConditionTree) import Distribution.ArchHs.Exception @@ -25,8 +25,9 @@ import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) import qualified Distribution.Types.BuildInfo.Lens as L import Distribution.Types.Dependency (Dependency) +import Distribution.Types.SetupBuildInfo import Distribution.Utils.ShortText (fromShortText) -import Network.HTTP.Req hiding (header) +import Network.HTTP.Client #ifndef ALPM import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) @@ -125,21 +126,33 @@ collectTestDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectTestDeps = collectRunnableDeps condTestSuites +collectSetupDeps :: Member Trace r => GenericPackageDescription -> Sem r VersionedList +collectSetupDeps cabal = do + let name = getPkgName' cabal + trace' $ "Getting setup dependencies of " <> show name + case setupBuildInfo $ packageDescription cabal of + Just (SetupBuildInfo deps _) -> do + let result = unDepV <$> deps + trace' $ "Found: " <> show result + return result + _ -> return [] + updateDependencyRecord :: Member DependencyRecord r => PackageName -> VersionRange -> Sem r () updateDependencyRecord name range = modify' $ Map.insertWith (<>) name [range] ----------------------------------------------------------------------------- -getCabalFromHackage :: Members [Embed IO, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription +getCabalFromHackage :: Members [Embed IO, WithMyErr, Reader Manager] r => PackageName -> Version -> Sem r GenericPackageDescription getCabalFromHackage name version = do - let urlPath = T.pack $ unPackageName name <> "-" <> prettyShow version - api = https "hackage.haskell.org" /: "package" /: urlPath /: "revision" /: "0.cabal" - r = req GET api NoReqBody bsResponse mempty - printInfo $ "Downloading cabal file from" <+> pretty (renderUrl api) - response <- interceptHttpException (runReq defaultHttpConfig r) - case parseGenericPackageDescriptionMaybe $ responseBody response of + let urlPath = unPackageName name <> "-" <> prettyShow version + s = "https://hackage.haskell.org/package/" <> urlPath <> "/revision/0.cabal" + req <- interceptHttpException $ parseRequest s + printInfo $ "Downloading cabal file from" <+> pretty s + manager <- ask @Manager + response <- interceptHttpException $ httpLbs req manager + case parseGenericPackageDescriptionMaybe . LBS.toStrict $ responseBody response of Just x -> return x - _ -> error $ "Failed to parse .cabal file from " <> show api + _ -> error "Failed to parse .cabal file" directDependencies :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => @@ -149,6 +162,7 @@ (libDeps, libToolsDeps) <- collectLibDeps cabal (exeDeps, exeToolsDeps) <- collectExeDeps cabal [] (testDeps, testToolsDeps) <- collectTestDeps cabal [] + setupDeps <- collectSetupDeps cabal let flatten = mconcat . fmap snd l = libDeps lt = libToolsDeps @@ -159,13 +173,13 @@ notMyself = (/= getPkgName' cabal) distinct = filter (notMyself . fst) . nub depends = distinct $ l <> e - makedepends = distinct (lt <> et <> t <> tt) \\ depends + makedepends = distinct (lt <> et <> t <> tt <> setupDeps) \\ depends sort' = sortBy (\x y -> uncurry compare $ getTwo _1 x y) return (sort' depends, sort' makedepends) ----------------------------------------------------------------------------- -diffCabal :: Members [CommunityEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Embed IO] r => PackageName -> Version -> Version -> Sem r () +diffCabal :: Members [CommunityEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Reader Manager, Embed IO] r => PackageName -> Version -> Version -> Sem r () diffCabal name a b = do ga <- getCabalFromHackage name a gb <- getCabalFromHackage name b @@ -188,7 +202,8 @@ dep "MakeDepends" ma mb, querym, flags name fa fb - ] <> line + ] + <> line diffTerm :: String -> (a -> String) -> a -> a -> Doc AnsiStyle diffTerm s f a b = @@ -240,11 +255,11 @@ <+> "but" <+> ppCommunity <+> "does not provide this package" - <> comma + <> dot new <- fmap (pp True) <$> mapM inRange diffNew old <- fmap (pp False) <$> mapM inRange diffOld - return $ hsep [cat old, cat new] + return $ vsep [cat old, cat new] dep :: Doc AnsiStyle -> VersionedList -> VersionedList -> Doc AnsiStyle dep s va vb = diff --git a/diff/Main.hs b/diff/Main.hs --- a/diff/Main.hs +++ b/diff/Main.hs @@ -13,6 +13,8 @@ import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.PP import Distribution.ArchHs.Types +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) main :: IO () main = printHandledIOException $ @@ -33,8 +35,23 @@ community <- loadCommunityDB optCommunityDBPath #endif + manager <- newTlsManager + printInfo "Start running..." - runDiff community optFlags (diffCabal optPackageName optVersionA optVersionB) & printAppResult + runDiff community optFlags manager (diffCabal optPackageName optVersionA optVersionB) & printAppResult -runDiff :: CommunityDB -> FlagAssignments -> Sem '[CommunityEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) -runDiff community flags = runFinal . embedToFinal . errorToIOFinal . evalState Map.empty . ignoreTrace . runReader flags . runReader community +runDiff :: + CommunityDB -> + FlagAssignments -> + Manager -> + Sem '[CommunityEnv, FlagAssignmentsEnv, Reader Manager, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> + IO (Either MyException a) +runDiff community flags manager = + runFinal + . embedToFinal + . errorToIOFinal + . evalState Map.empty + . ignoreTrace + . runReader manager + . runReader flags + . runReader community diff --git a/src/Data/Aeson/Ext.hs b/src/Data/Aeson/Ext.hs deleted file mode 100644 --- a/src/Data/Aeson/Ext.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} - -module Data.Aeson.Ext - ( generateJSONInstance, - parseJSONDrop, - toJSONDrop, - ) -where - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics (Generic, Rep) -import Language.Haskell.TH - -dropSize :: Type -> Q Int -dropSize (ConT n) = do - info <- reify n - case info of - (TyConI (DataD _ _ [] _ cons _)) -> go cons - (TyConI (NewtypeD _ _ _ _ con _)) -> go [con] - _ -> fail "Unsupported." - where - -- Try only the first record constructor - rec (x : _) = case x of - (RecC _ f) -> f - _ -> fail "Unsupported" - rec [] = fail "Unsupported" - go cons = do - let fields = rec cons - -- Find prefix from the first field - let (name, _, _) = head fields - let str = nameBase name - return . (+ 1) $ length str - length (dropWhile (/= '_') str) -dropSize _ = fail "Unsupported" - -generateToJSONInstance :: Name -> DecQ -generateToJSONInstance targetType = - conT targetType >>= dropSize >>= \s -> instanceD (cxt []) (appT (conT ''ToJSON) (conT targetType)) [gen_f $ fromIntegral s] - where - gen_f s = funD (mkName "toJSON") [clause [] (normalB (varE 'toJSONDrop `appE` litE (integerL s))) []] - -generateFromJSONInstance :: Name -> DecQ -generateFromJSONInstance targetType = - conT targetType >>= dropSize >>= \s -> instanceD (cxt []) (appT (conT ''FromJSON) (conT targetType)) [gen_f $ fromIntegral s] - where - gen_f s = funD (mkName "parseJSON") [clause [] (normalB (varE 'parseJSONDrop `appE` litE (integerL s))) []] - -generateJSONInstance :: Name -> Q [Dec] -generateJSONInstance name = do - from <- generateFromJSONInstance name - to <- generateToJSONInstance name - return [from, to] - -toJSONDrop :: - forall a. - (Generic a, GToJSON Zero (Rep a)) => - Int -> - a -> - Value -toJSONDrop prefix = - genericToJSON defaultOptions {fieldLabelModifier = drop prefix, omitNothingFields = True, sumEncoding = UntaggedValue} - -parseJSONDrop :: - forall a. - (Generic a, GFromJSON Zero (Rep a)) => - Int -> - Value -> - Parser a -parseJSONDrop prefix = genericParseJSON defaultOptions {fieldLabelModifier = drop prefix, sumEncoding = UntaggedValue} diff --git a/src/Distribution/ArchHs/Aur.hs b/src/Distribution/ArchHs/Aur.hs --- a/src/Distribution/ArchHs/Aur.hs +++ b/src/Distribution/ArchHs/Aur.hs @@ -1,154 +1,46 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module supports searching. module Distribution.ArchHs.Aur - ( AurReply (..), - AurSearch (..), - AurInfo (..), - Aur, - searchByName, - infoByName, + ( Aur, isInAur, aurToIO, ) where -import Data.Aeson -import Data.Aeson.Ext (generateJSONInstance) -import Data.Text (Text, pack) +import qualified Data.Text as T import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Name import Distribution.ArchHs.Types -import Network.HTTP.Req - --- | AUR response -data AurReply a = AurReply - { r_version :: Int, - r_type :: String, - r_resultcount :: Int, - r_results :: [a] - } - deriving stock (Show, Generic) - --- | AUR search result -data AurSearch = AurSearch - { s_ID :: Int, - s_Name :: String, - s_PackageBaseID :: Int, - s_PackageBase :: String, - s_Version :: String, - s_Description :: String, - s_URL :: String, - s_NumVotes :: Int, - s_Popularity :: Double, - s_OutOfDate :: Maybe Int, - s_Maintainer :: Maybe String, - s_FirstSubmitted :: Int, -- UTC - s_LastModified :: Int, -- UTC - s_URLPath :: String - } - deriving stock (Show, Generic) - --- | AUR info result -data AurInfo = AurInfo - { i_ID :: Int, - i_Name :: String, - i_PackageBaseID :: Int, - i_PackageBase :: String, - i_Version :: String, - i_Description :: String, - i_URL :: String, - i_NumVotes :: Int, - i_Popularity :: Double, - i_OutOfDate :: Maybe Int, - i_Maintainer :: Maybe String, - i_FirstSubmitted :: Int, -- UTC - i_LastModified :: Int, -- UTC - i_URLPath :: String, - i_Depends :: Maybe [String], - i_MakeDepends :: Maybe [String], - i_OptDepends :: Maybe [String], - i_CheckDepends :: Maybe [String], - i_Conflicts :: Maybe [String], - i_Provides :: Maybe [String], - i_Replaces :: Maybe [String], - i_Groups :: Maybe [String], - i_License :: Maybe [String], - i_Keywords :: Maybe [String] - } - deriving stock (Show, Generic) - -instance (FromJSON a) => FromJSON (AurReply a) where - parseJSON (Object v) = - AurReply - <$> v .: "version" - <*> v .: "type" - <*> v .: "resultcount" - <*> v .: "results" - parseJSON _ = fail "Unable to parse AUR reply." - -instance (ToJSON a) => ToJSON (AurReply a) - -$(generateJSONInstance ''AurSearch) -$(generateJSONInstance ''AurInfo) +import Network.HTTP.Client (Manager) +import Web.ArchLinux -- | AUR Effect data Aur m a where - SearchByName :: String -> Aur m (Maybe AurSearch) - InfoByName :: String -> Aur m (Maybe AurInfo) IsInAur :: HasMyName n => n -> Aur m Bool makeSem_ ''Aur --- | Search a package from AUR -searchByName :: Member Aur r => String -> Sem r (Maybe AurSearch) - --- | Get package info from AUR -infoByName :: Member Aur r => String -> Sem r (Maybe AurInfo) - -- | Check whether a __haskell__ package exists in AUR isInAur :: (HasMyName n, Member Aur r) => n -> Sem r Bool -baseURL :: Url 'Https -baseURL = https "aur.archlinux.org" /: "rpc" -- | Run 'Aur' effect. -aurToIO :: Members [WithMyErr, Embed IO] r => Sem (Aur ': r) a -> Sem r a -aurToIO = interpret $ \case - (SearchByName name) -> do - let parms = - "v" =: ("5" :: Text) - <> "type" =: ("search" :: Text) - <> "by" =: ("name" :: Text) - <> "arg" =: pack name - r = req GET baseURL NoReqBody jsonResponse parms - response <- interceptHttpException $ runReq defaultHttpConfig r - let body :: AurReply AurSearch = responseBody response - return $ case r_resultcount body of - 1 -> Just . head $ r_results body - _ -> Nothing - (InfoByName name) -> do - let parms = - "v" =: ("5" :: Text) - <> "type" =: ("info" :: Text) - <> "by" =: ("name" :: Text) - <> "arg[]" =: pack name - r = req GET baseURL NoReqBody jsonResponse parms - response <- interceptHttpException $ runReq defaultHttpConfig r - let body :: AurReply AurInfo = responseBody response - return $ case r_resultcount body of - 1 -> Just . head $ r_results body - _ -> Nothing +aurToIO :: Manager -> Members [WithMyErr, Embed IO] r => Sem (Aur ': r) a -> Sem r a +aurToIO manager = interpret $ \case (IsInAur name) -> do - result <- aurToIO . searchByName . unArchLinuxName . toArchLinuxName $ name - return $ case result of - Just _ -> True - _ -> False + result <- embed . runAPIClient manager . searchAur ByName . T.pack $ unArchLinuxName . toArchLinuxName $ name + case result of + Left err -> throw $ NetworkException err + Right AurResponse {_results = [_]} -> return True + _ -> return False diff --git a/src/Distribution/ArchHs/CommunityDB.hs b/src/Distribution/ArchHs/CommunityDB.hs --- a/src/Distribution/ArchHs/CommunityDB.hs +++ b/src/Distribution/ArchHs/CommunityDB.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental diff --git a/src/Distribution/ArchHs/Core.hs b/src/Distribution/ArchHs/Core.hs --- a/src/Distribution/ArchHs/Core.hs +++ b/src/Distribution/ArchHs/Core.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -31,6 +31,7 @@ import Distribution.ArchHs.PkgBuild ( PkgBuild (..), mapLicense, + showArchLicense, ) import Distribution.ArchHs.Types import Distribution.ArchHs.Utils @@ -259,15 +260,15 @@ cabalToPkgBuild pkg uusi sysDeps = do let name = pkg ^. pkgName cabal <- packageDescription <$> getLatestCabal name - _sha256sums <- (\case Just s -> "'" <> s <> "'"; Nothing -> "'SKIP'") <$> tryMaybe (getLatestSHA256 name) + _sha256sums <- (\case Just s -> "'" <> s <> "'"; Nothing -> "'SKIP'") <$> getLatestSHA256 name let _hkgName = pkg ^. pkgName & unPackageName _pkgName = unArchLinuxName . toArchLinuxName $ pkg ^. pkgName _pkgVer = prettyShow $ getPkgVersion cabal _pkgDesc = fromShortText $ synopsis cabal getL NONE = "" getL (License e) = getE e - getE (ELicense (ELicenseId x) _) = show . mapLicense $ x - getE (ELicense (ELicenseIdPlus x) _) = show . mapLicense $ x + getE (ELicense (ELicenseId x) _) = showArchLicense . mapLicense $ x + getE (ELicense (ELicenseIdPlus x) _) = showArchLicense . mapLicense $ x getE (ELicense (ELicenseRef x) _) = "custom:" <> licenseRef x getE (EAnd x y) = getE x <> " " <> getE y getE (EOr x y) = getE x <> " " <> getE y diff --git a/src/Distribution/ArchHs/Exception.hs b/src/Distribution/ArchHs/Exception.hs --- a/src/Distribution/ArchHs/Exception.hs +++ b/src/Distribution/ArchHs/Exception.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -14,8 +14,8 @@ MyException (..), printHandledIOException, printAppResult, - interceptHttpException, tryMaybe, + interceptHttpException, ) where @@ -24,7 +24,8 @@ import Distribution.ArchHs.Name import Distribution.ArchHs.PP (colon, printError, printSuccess, viaShow, (<+>)) import Distribution.ArchHs.Types -import Network.HTTP.Req (HttpException (..)) +import Network.HTTP.Client (HttpException) +import Servant.Client (ClientError (ConnectionError)) -- | Error effect of 'MyException' type WithMyErr = Error MyException @@ -35,7 +36,7 @@ | VersionNotFound PackageName Version | TargetExist PackageName DependencyProvider | CyclicExist [PackageName] - | NetworkException HttpException + | NetworkException ClientError | TargetDisappearException PackageName instance Show MyException where @@ -43,8 +44,7 @@ show (VersionNotFound name version) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\" " <> prettyShow version show (TargetExist name provider) = "Target \"" <> unPackageName name <> "\" has been provided by " <> show provider show (CyclicExist c) = "Graph contains a cycle \"" <> show (fmap unPackageName c) <> "\"" - show (NetworkException (JsonHttpException s)) = "Failed to parse response " <> s - show (NetworkException (VanillaHttpException e)) = show e + show (NetworkException e) = show e show (TargetDisappearException name) = "Target \"" <> unPackageName name <> "\" is discarded during the dependency resolving" -- | Catch 'CE.IOException' and print it. @@ -58,17 +58,17 @@ Left x -> printError $ "Runtime Exception" <> colon <+> viaShow x _ -> printSuccess "Success!" --- | Catch the 'HttpException' thrown in 'IO' monad, then re-throw it with 'NetworkException'. -interceptHttpException :: Members [WithMyErr, Embed IO] r => IO a -> Sem r a -interceptHttpException io = do - x <- embed $ CE.try io - case x of - Left err -> throw $ NetworkException err - Right x' -> return x' - -- | Like 'try' but discard the concrete exception. tryMaybe :: Member WithMyErr r => Sem r a -> Sem r (Maybe a) tryMaybe m = try @MyException m >>= \case Left _ -> return Nothing Right x -> return $ Just x + +-- | Catch the 'HttpException' thrown in 'IO' monad, then re-throw it with 'NetworkException'. +interceptHttpException :: Members [WithMyErr, Embed IO] r => IO a -> Sem r a +interceptHttpException io = do + x <- embed $ CE.try io + case x of + Left (err :: HttpException) -> throw . NetworkException . ConnectionError . CE.SomeException $ err + Right x' -> return x' diff --git a/src/Distribution/ArchHs/FilesDB.hs b/src/Distribution/ArchHs/FilesDB.hs --- a/src/Distribution/ArchHs/FilesDB.hs +++ b/src/Distribution/ArchHs/FilesDB.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental diff --git a/src/Distribution/ArchHs/Hackage.hs b/src/Distribution/ArchHs/Hackage.hs --- a/src/Distribution/ArchHs/Hackage.hs +++ b/src/Distribution/ArchHs/Hackage.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeApplications #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -79,8 +79,8 @@ getLatestCabal = withLatestVersion cabalFile -- | Get the latest SHA256 sum of the tarball . -getLatestSHA256 :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r String -getLatestSHA256 = withLatestVersion (\vdata -> tarballHashes vdata Map.! "sha256") +getLatestSHA256 :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r (Maybe String) +getLatestSHA256 = withLatestVersion (\vdata -> tarballHashes vdata Map.!? "sha256") -- | Get 'GenericPackageDescription' with a specific version. getCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription diff --git a/src/Distribution/ArchHs/Local.hs b/src/Distribution/ArchHs/Local.hs --- a/src/Distribution/ArchHs/Local.hs +++ b/src/Distribution/ArchHs/Local.hs @@ -1,4 +1,4 @@ --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -32,7 +32,9 @@ "ghc-bignum", "hans", "Win32", - "ghc-heap" + "ghc-heap", + -- a build-tools of "zip-archive", which is not haskell package + "unzip" ] -- | Packages already provided by . 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 @@ -5,7 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -40,8 +40,8 @@ -- For details, see the type 'MyName' and type class 'HasMyName' with its instances. module Distribution.ArchHs.Name ( MyName, - HasMyName, NameRep (..), + HasMyName (..), toArchLinuxName, toHackageName, isHaskellPackage, diff --git a/src/Distribution/ArchHs/OptionReader.hs b/src/Distribution/ArchHs/OptionReader.hs --- a/src/Distribution/ArchHs/OptionReader.hs +++ b/src/Distribution/ArchHs/OptionReader.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental diff --git a/src/Distribution/ArchHs/PP.hs b/src/Distribution/ArchHs/PP.hs --- a/src/Distribution/ArchHs/PP.hs +++ b/src/Distribution/ArchHs/PP.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -127,8 +127,8 @@ ( \(i :: Int, SolvedDependency {..}) -> let prefix = if i == length _pkgDeps then " └─" else " ├─" in case _depProvider of - (Just x) -> (annGreen $ prefix <> viaPretty _depName <+> viaShow _depType, dui <+> annCyan (viaShow x)) - _ -> (annYellow . annBold $ prefix <> viaPretty _depName <+> viaShow _depType, indent 16 cuo) + (Just x) -> (annGreen $ prefix <> viaPretty _depName <+> tupled (viaShow <$> _depType), dui <+> annCyan (viaShow x)) + _ -> (annYellow . annBold $ prefix <> viaPretty _depName <+> tupled (viaShow <$> _depType), indent 16 cuo) ) (zip [1 ..] _pkgDeps) prettySolvedPkg ProvidedPackage {..} = [(annGreen $ viaPretty _pkgName, dui <+> annCyan (viaShow _pkgProvider))] diff --git a/src/Distribution/ArchHs/PkgBuild.hs b/src/Distribution/ArchHs/PkgBuild.hs --- a/src/Distribution/ArchHs/PkgBuild.hs +++ b/src/Distribution/ArchHs/PkgBuild.hs @@ -2,7 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental @@ -10,17 +10,20 @@ -- Template of PKGBUILD file. module Distribution.ArchHs.PkgBuild ( PkgBuild (..), - ArchLicense, mapLicense, + showArchLicense, applyTemplate, felixTemplate, metaTemplate, ) where +import qualified Data.Aeson as A import Data.Text (Text, pack, unpack) +import qualified Data.Text as T import Distribution.SPDX.LicenseId import NeatInterpolation (text) +import qualified Web.ArchLinux.Types as Arch -- | PkgBuild data type, representing needed information in filling the 'felixTemplate'. data PkgBuild = PkgBuild @@ -50,83 +53,38 @@ _enableCheck :: Bool } --- | Licenses available in . -data ArchLicense - = AGPL3 - | Apache - | Artistic2_0 - | CDDL - | CPL - | EPL - | FDL1_2 - | FDL1_3 - | GPL2 - | GPL3 - | LGPL2_1 - | LGPL3 - | LPPL - | MPL - | MPL2 - | PHP - | PSF - | PerlArtistic - | RUBY - | Unlicense - | W3C - | ZPL - | Custom String - -instance Show ArchLicense where - show AGPL3 = "AGPL" - show Apache = "Apache" - show Artistic2_0 = "Artistic2.0" - show CDDL = "CDDL" - show CPL = "CPL" - show EPL = "EPL" - show FDL1_2 = "FDL1.2" - show FDL1_3 = "FDL1.3" - show GPL2 = "GPL2" - show GPL3 = "GPL3" - show LGPL2_1 = "LGPL2.1" - show LGPL3 = "LGPL3" - show LPPL = "LPPL" - show MPL = "MPL" - show MPL2 = "MPL2" - show PHP = "PHP" - show PSF = "PSF" - show PerlArtistic = "PerlArtistic" - show RUBY = "RUBY" - show Distribution.ArchHs.PkgBuild.Unlicense = "Unlicense" - show Distribution.ArchHs.PkgBuild.W3C = "W3C" - show ZPL = "ZPL" - show (Custom x) = "custom:" <> x - -- | Map 'LicenseId' to 'ArchLicense'. License not provided by system will be mapped to @custom:...@. -mapLicense :: LicenseId -> ArchLicense -mapLicense AGPL_3_0_only = AGPL3 -mapLicense Apache_2_0 = Apache -mapLicense Artistic_2_0 = Artistic2_0 -mapLicense CDDL_1_0 = CDDL -mapLicense CPL_1_0 = CPL -mapLicense EPL_1_0 = EPL -mapLicense GFDL_1_2_only = FDL1_2 -mapLicense GFDL_1_3_only = FDL1_3 -mapLicense GPL_2_0_only = GPL2 -mapLicense GPL_3_0_only = GPL3 -mapLicense LGPL_2_1_only = LGPL2_1 -mapLicense LGPL_3_0_only = LGPL3 -mapLicense LPPL_1_3c = LPPL -mapLicense MPL_1_0 = MPL -mapLicense MPL_2_0 = MPL2 -mapLicense PHP_3_01 = PHP -mapLicense Python_2_0 = PSF -mapLicense Artistic_1_0_Perl = PerlArtistic -mapLicense Ruby = RUBY -mapLicense ZPL_2_1 = ZPL -mapLicense Distribution.SPDX.LicenseId.Unlicense = Distribution.ArchHs.PkgBuild.Unlicense -mapLicense Distribution.SPDX.LicenseId.W3C = Distribution.ArchHs.PkgBuild.W3C -mapLicense BSD_3_Clause = Custom "BSD3" -mapLicense x = Custom $ show x +mapLicense :: LicenseId -> Arch.License +mapLicense AGPL_3_0_only = Arch.AGPL3 +mapLicense Apache_2_0 = Arch.Apache +mapLicense Artistic_2_0 = Arch.Artistic2_0 +mapLicense CDDL_1_0 = Arch.CDDL +mapLicense CPL_1_0 = Arch.CPL +mapLicense EPL_1_0 = Arch.EPL +mapLicense GFDL_1_2_only = Arch.FDL1_2 +mapLicense GFDL_1_3_only = Arch.FDL1_3 +mapLicense GPL_2_0_only = Arch.GPL2 +mapLicense GPL_3_0_only = Arch.GPL3 +mapLicense LGPL_2_1_only = Arch.LGPL2_1 +mapLicense LGPL_3_0_only = Arch.LGPL3 +mapLicense LPPL_1_3c = Arch.LPPL +mapLicense MPL_1_0 = Arch.MPL +mapLicense MPL_2_0 = Arch.MPL2 +mapLicense PHP_3_01 = Arch.PHP +mapLicense Python_2_0 = Arch.PSF +mapLicense Artistic_1_0_Perl = Arch.PerlArtistic +mapLicense Ruby = Arch.RUBY +mapLicense ZPL_2_1 = Arch.ZPL +mapLicense Unlicense = Arch.Unlicense +mapLicense W3C = Arch.W3C +mapLicense BSD_3_Clause = Arch.Custom "BSD3" +mapLicense x = Arch.Custom . T.pack $ show x + +-- | Show an archlinux license +showArchLicense :: Arch.License -> String +showArchLicense license = case A.toJSON license of + (A.String x) -> T.unpack x + _ -> error "impossible" -- | Apply 'PkgBuild' to 'felixTemplate'. applyTemplate :: PkgBuild -> String diff --git a/src/Distribution/ArchHs/PkgDesc.hs b/src/Distribution/ArchHs/PkgDesc.hs --- a/src/Distribution/ArchHs/PkgDesc.hs +++ b/src/Distribution/ArchHs/PkgDesc.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental diff --git a/src/Distribution/ArchHs/Types.hs b/src/Distribution/ArchHs/Types.hs --- a/src/Distribution/ArchHs/Types.hs +++ b/src/Distribution/ArchHs/Types.hs @@ -6,7 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental 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,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} --- | Copyright: (c) 2020 berberman +-- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman -- Stability: experimental diff --git a/submit/Main.hs b/submit/Main.hs --- a/submit/Main.hs +++ b/submit/Main.hs @@ -11,6 +11,8 @@ import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.PP import Distribution.ArchHs.Types +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) import Submit import System.Directory (doesFileExist) import System.Environment (lookupEnv) @@ -50,7 +52,20 @@ hackage <- loadHackageDB hackagePath - runSubmit community hackage (submit token optOutput optUpload) & printAppResult + manager <- newTlsManager -runSubmit :: CommunityDB -> HackageDB -> Sem '[CommunityEnv, HackageEnv, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) -runSubmit community hackage = runFinal . embedToFinal . errorToIOFinal . runReader hackage . runReader community + 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 --- a/submit/Submit.hs +++ b/submit/Submit.hs @@ -12,6 +12,7 @@ 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 (catMaybes, fromJust) import qualified Data.Text as T @@ -24,7 +25,7 @@ import Distribution.ArchHs.PP import Distribution.ArchHs.Types import Distribution.ArchHs.Utils (filterFirstDiff, filterSecondDiff, mapDiff, noDiff) -import Network.HTTP.Req +import Network.HTTP.Client import Options.Applicative hiding (header) import qualified Options.Applicative import qualified Text.Megaparsec as M @@ -138,7 +139,7 @@ in (unPackageName hackageName, version, prefix <> archLinuxName') return $ processField <$> fields -submit :: Members [HackageEnv, CommunityEnv, WithMyErr, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r () +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 @@ -147,20 +148,26 @@ printInfo $ "Write file" <> colon <+> pretty output writeFile output v check csv + manager <- ask interceptHttpException $ when ((not . null) token && upload) $ do printInfo "Uploading..." - let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages" - r = - req PUT api (ReqBodyBs . BS.pack $ v) bsResponse $ - header "Authorization" (BS.pack $ "X-ApiKey " <> fromJust token) <> header "Content-Type" "text/csv" - result <- runReq defaultHttpConfig r - printInfo $ "StatusCode" <> colon <+> pretty (responseStatusCode result) - printInfo $ "ResponseMessage" <> colon <+> pretty (decodeUtf8 (responseStatusMessage result)) + 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:" - putStrLn . BS.unpack $ responseBody result + printInfo . pretty . decodeUtf8 . LBS.toStrict $ responseBody result -check :: Members [HackageEnv, WithMyErr, Embed IO] r => DistroCSV -> Sem r () +check :: Members [HackageEnv, WithMyErr, Reader Manager, Embed IO] r => DistroCSV -> Sem r () check community = do printInfo "Checking generated csv file..." @@ -170,16 +177,16 @@ failed <- catMaybes . f <$> mapM (\x -> try @MyException (getLatestCabal $ mkPackageName x)) hackageNames unless (null failed) $ - printWarn "Following packages in community are not linked to hackage:" + printWarn $ "Following packages in" <+> ppCommunity <+> "are not linked to hackage:" embed . putStr . unlines $ failed - let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages.csv" - r = req GET api NoReqBody bsResponse mempty + req <- interceptHttpException $ parseRequest "https://hackage.haskell.org/distro/Arch/packages.csv" printInfo "Downloading csv from hackage..." - result <- interceptHttpException $ runReq defaultHttpConfig r + manager <- ask + result <- interceptHttpException $ httpLbs req manager let bs = responseBody result - hackage = parseDistroCSV . T.unpack $ decodeUtf8 bs + hackage = parseDistroCSV . T.unpack . decodeUtf8 . LBS.toStrict $ bs let diff = getGroupedDiff hackage community diffOld = filterFirstDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord))