diff options
| -rw-r--r-- | guix/import/cran.scm | 194 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 90 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 207 | ||||
| -rw-r--r-- | guix/import/stackage.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 4 | ||||
| -rw-r--r-- | guix/upstream.scm | 163 | ||||
| -rw-r--r-- | tests/pypi.scm | 62 | ||||
| -rw-r--r-- | tests/upstream.scm | 140 |
8 files changed, 511 insertions, 358 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index bb271634ed..d25f334396 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> @@ -164,24 +164,16 @@ rest))))))) (fold parse '() lines))) -(define (format-inputs names) - "Generate a sorted list of package inputs from a list of package NAMES." - (map (lambda (name) - (case (%input-style) - ((specification) - `(specification->package ,name)) - (else - (string->symbol name)))) - (sort names string-ci<?))) - -(define* (maybe-inputs package-inputs #:optional (type 'inputs)) +(define* (maybe-inputs package-inputs #:optional (input-type 'inputs)) "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a package definition." (match package-inputs (() '()) ((package-inputs ...) - `((,type (list ,@(format-inputs package-inputs))))))) + `((,input-type (list ,@(map (compose string->symbol + upstream-input-downstream-name) + package-inputs))))))) (define %cran-url "https://cran.r-project.org/web/packages/") (define %cran-canonical-url "https://cran.r-project.org/package=") @@ -520,14 +512,29 @@ the pkg-config tool." "(Makevars.*|configure.*)")) (define (source-dir->dependencies dir) - "Guess dependencies of R package source in DIR and return two values: a list -of package names for INPUTS and another list of names of NATIVE-INPUTS." - (values - (needed-libraries-in-directory dir) - (append - (if (directory-needs-esbuild? dir) '("esbuild") '()) - (if (directory-needs-pkg-config? dir) '("pkg-config") '()) - (if (directory-needs-fortran? dir) '("gfortran") '())))) + "Guess dependencies of R package source in DIR and return a list of +<upstream-input> corresponding to the dependencies guessed from source files +in DIR." + (define (native name) + (upstream-input + (name name) + (downstream-name name) + (type 'native))) + + (append (map (lambda (name) + (upstream-input + (name name) + (downstream-name (cran-guix-name name)))) + (needed-libraries-in-directory dir)) + (if (directory-needs-esbuild? dir) + (list (native "esbuild")) + '()) + (if (directory-needs-pkg-config? dir) + (list (native "pkg-config")) + '()) + (if (directory-needs-fortran? dir) + (list (native "gfortran")) + '()))) (define (source->dependencies source tarball?) "SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated @@ -541,7 +548,79 @@ by TARBALL?" (source-dir->dependencies source))) (define (vignette-builders meta) - (map cran-guix-name (listify meta "VignetteBuilder"))) + (map (lambda (name) + (upstream-input + (name name) + (downstream-name (cran-guix-name name)) + (type 'native))) + (listify meta "VignetteBuilder"))) + +(define (uri-helper repository) + (match repository + ('cran cran-uri) + ('bioconductor bioconductor-uri) + ('git #f) + ('hg #f))) + +(define (cran-package-source-url meta repository) + "Return the URL of the source code referred to by META, a package in +REPOSITORY." + (case repository + ((git) (assoc-ref meta 'git)) + ((hg) (assoc-ref meta 'hg)) + (else + (match (apply (uri-helper repository) + (assoc-ref meta "Package") + (assoc-ref meta "Version") + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) + ((urls ...) urls) + ((? string? url) url) + (_ #f))))) + +(define (cran-package-propagated-inputs meta) + "Return the list of <upstream-input> derived from dependency information in +META." + (filter-map (lambda (name) + (and (not (member name + (append default-r-packages invalid-packages))) + (upstream-input + (name name) + (downstream-name (cran-guix-name name)) + (type 'propagated)))) + (lset-union equal? + (listify meta "Imports") + (listify meta "LinkingTo") + (delete "R" (listify meta "Depends"))))) + +(define* (cran-package-inputs meta repository + #:key (download-source download)) + "Return the list of <upstream-input> corresponding to all the dependencies +of META, a package in REPOSITORY." + (let* ((url (cran-package-source-url meta repository)) + (source (download-source url + #:method + (cond ((assoc-ref meta 'git) 'git) + ((assoc-ref meta 'hg) 'hg) + (else #f)))) + (tarball? (not (or (assoc-ref meta 'git) + (assoc-ref meta 'hg))))) + (sort (append (source->dependencies source tarball?) + (filter-map (lambda (name) + (and (not (member name invalid-packages)) + (upstream-input + (name name) + (downstream-name + (transform-sysname name))))) + (map string-downcase + (listify meta "SystemRequirements"))) + (cran-package-propagated-inputs meta) + (vignette-builders meta)) + (lambda (input1 input2) + (string<? (upstream-input-downstream-name input1) + (upstream-input-downstream-name input2)))))) (define* (description->package repository meta #:key (license-prefix identity) (download-source download)) @@ -556,11 +635,6 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((cran) %cran-canonical-url) ((bioconductor) %bioconductor-url) ((git) #f))) - (uri-helper (case repository - ((cran) cran-uri) - ((bioconductor) bioconductor-uri) - ((git) #f) - ((hg) #f))) (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) @@ -572,40 +646,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (else (match (listify meta "URL") ((url rest ...) url) (_ (string-append canonical-url-base name)))))) - (source-url (case repository - ((git) (assoc-ref meta 'git)) - ((hg) (assoc-ref meta 'hg)) - (else - (match (apply uri-helper name version - (case repository - ((bioconductor) - (list (assoc-ref meta 'bioconductor-type))) - (else '()))) - ((urls ...) urls) - ((? string? url) url) - (_ #f))))) + (source-url (cran-package-source-url meta repository)) (git? (if (assoc-ref meta 'git) #true #false)) (hg? (if (assoc-ref meta 'hg) #true #false)) (source (download-source source-url #:method (cond (git? 'git) (hg? 'hg) (else #f)))) - (tarball? (not (or git? hg?))) - (source-inputs source-native-inputs - (source->dependencies source tarball?)) - (sysdepends (append - source-inputs - (filter (lambda (name) - (not (member name invalid-packages))) - (map string-downcase (listify meta "SystemRequirements"))))) - (propagate (filter (lambda (name) - (not (member name (append default-r-packages - invalid-packages)))) - (lset-union equal? - (listify meta "Imports") - (listify meta "LinkingTo") - (delete "R" - (listify meta "Depends"))))) + (uri-helper (uri-helper repository)) + (inputs (cran-package-inputs meta repository + #:download-source download-source)) (package `(package (name ,(cran-guix-name name)) @@ -651,12 +701,18 @@ from the alist META, which was derived from the R package's DESCRIPTION file." `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) - ,@(maybe-inputs (map transform-sysname sysdepends)) - ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) - ,@(maybe-inputs - `(,@source-native-inputs - ,@(vignette-builders meta)) - 'native-inputs) + + ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular) + inputs) + 'inputs) + ,@(maybe-inputs (filter (upstream-input-type-predicate + 'propagated) + inputs) + 'propagated-inputs) + ,@(maybe-inputs (filter (upstream-input-type-predicate 'native) + inputs) + 'native-inputs) + (home-page ,(if (string-null? home-page) (string-append base-url name) home-page)) @@ -675,7 +731,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (revision "1")) ,package)) (else package)) - propagate))) + (filter-map (lambda (input) + (and (eq? 'propagated (upstream-input-type input)) + (upstream-input-name input))) + inputs)))) (define cran->guix-package (memoize @@ -760,9 +819,7 @@ s-expression corresponding to that package, or #f on failure." (package (package-name pkg)) (version version) (urls (cran-uri upstream-name version)) - (input-changes - (changed-inputs pkg - (description->package 'cran meta))))))) + (inputs (cran-package-inputs meta 'cran)))))) (define* (latest-bioconductor-release pkg #:key (version #f)) "Return an <upstream-source> for the latest release of the package PKG." @@ -784,10 +841,9 @@ s-expression corresponding to that package, or #f on failure." (package (package-name pkg)) (version latest-version) (urls (bioconductor-uri upstream-name latest-version)) - (input-changes - (changed-inputs - pkg - (cran->guix-package upstream-name #:repo 'bioconductor)))))) + (inputs + (let ((meta (fetch-description 'bioconductor upstream-name))) + (cran-package-inputs meta 'bioconductor)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 56c8696ad7..9333bedbbd 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,7 +57,9 @@ hackage-fetch hackage-source-url hackage-cabal-url - hackage-package?)) + hackage-package? + + cabal-package-inputs)) (define ghc-standard-libraries ;; List of libraries distributed with ghc (as of 8.10.7). @@ -224,27 +227,12 @@ references to itself." (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies))) dependencies))) -(define* (hackage-module->sexp cabal cabal-hash - #:key (include-test-dependencies? #t)) - "Return the `package' S-expression for a Cabal package. CABAL is the -representation of a Cabal file as produced by 'read-cabal'. CABAL-HASH is -the hash of the Cabal file." - - (define name - (cabal-package-name cabal)) - - (define version - (cabal-package-version cabal)) - - (define revision - (cabal-package-revision cabal)) - - (define source-url - (hackage-source-url name version)) - - (define own-names (cons (cabal-package-name cabal) - (filter (lambda (x) (not (eqv? x #f))) - (map cabal-library-name (cabal-package-library cabal))))) +(define* (cabal-package-inputs cabal #:key (include-test-dependencies? #t)) + "Return the list of <upstream-input> for CABAL representing its +dependencies." + (define own-names + (cons (cabal-package-name cabal) + (filter-map cabal-library-name (cabal-package-library cabal)))) (define hackage-dependencies (filter-dependencies (cabal-dependencies->names cabal) own-names)) @@ -261,22 +249,54 @@ the hash of the Cabal file." hackage-dependencies)) (define dependencies - (map string->symbol - (map hackage-name->package-name - hackage-dependencies))) + (map (lambda (name) + (upstream-input + (name name) + (downstream-name (hackage-name->package-name name)) + (type 'regular))) + hackage-dependencies)) (define native-dependencies - (map string->symbol - (map hackage-name->package-name - hackage-native-dependencies))) - + (map (lambda (name) + (upstream-input + (name name) + (downstream-name (hackage-name->package-name name)) + (type 'native))) + hackage-native-dependencies)) + + (append dependencies native-dependencies)) + +(define* (hackage-module->sexp cabal cabal-hash + #:key (include-test-dependencies? #t)) + "Return the `package' S-expression for a Cabal package. CABAL is the +representation of a Cabal file as produced by 'read-cabal'. CABAL-HASH is +the hash of the Cabal file." + (define name + (cabal-package-name cabal)) + + (define version + (cabal-package-version cabal)) + + (define revision + (cabal-package-revision cabal)) + + (define source-url + (hackage-source-url name version)) + + (define inputs + (cabal-package-inputs cabal + #:include-test-dependencies? + include-test-dependencies?)) + (define (maybe-inputs input-type inputs) (match inputs (() '()) ((inputs ...) (list (list input-type - `(list ,@inputs)))))) + `(list ,@(map (compose string->symbol + upstream-input-downstream-name) + inputs))))))) (define (maybe-arguments) (match (append (if (not include-test-dependencies?) @@ -304,14 +324,18 @@ the hash of the Cabal file." "failed to download tar archive"))))) (build-system haskell-build-system) (properties '((upstream-name . ,name))) - ,@(maybe-inputs 'inputs dependencies) - ,@(maybe-inputs 'native-inputs native-dependencies) + ,@(maybe-inputs 'inputs + (filter (upstream-input-type-predicate 'regular) + inputs)) + ,@(maybe-inputs 'native-inputs + (filter (upstream-input-type-predicate 'native) + inputs)) ,@(maybe-arguments) (home-page ,(cabal-package-home-page cabal)) (synopsis ,(cabal-package-synopsis cabal)) (description ,(beautify-description (cabal-package-description cabal))) (license ,(string->license (cabal-package-license cabal)))) - (append hackage-dependencies hackage-native-dependencies)))) + inputs))) (define* (hackage->guix-package package-name #:key (include-test-dependencies? #t) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 8c06b19cff..1a3070fb36 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -33,12 +33,16 @@ (define-module (guix import pypi) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:use-module (ice-9 receive) #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) + #:autoload (gcrypt hash) (port-sha256) + #:autoload (guix base16) (base16-string->bytevector) + #:autoload (guix base32) (bytevector->nix-base32-string) + #:autoload (guix http-client) (http-fetch) #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix diagnostics) @@ -126,6 +130,12 @@ (python-version distribution-package-python-version "python_version")) +(define (distribution-sha256 distribution) + "Return the SHA256 hash of DISTRIBUTION as a bytevector, or #f." + (match (assoc-ref (distribution-digests distribution) "sha256") + (#f #f) + (str (base16-string->bytevector str)))) + (define (pypi-fetch name) "Return a <pypi-project> record for package NAME, or #f on failure." (and=> (json-fetch (string-append (%pypi-base-url) name "/json")) @@ -198,7 +208,9 @@ the input field." (() '()) ((package-inputs ...) - `((,input-type (list ,@package-inputs)))))) + `((,input-type (list ,@(map (compose string->symbol + upstream-input-downstream-name) + package-inputs))))))) (define %requirement-name-regexp ;; Regexp to match the requirement name in a requirement specification. @@ -409,23 +421,36 @@ cannot determine package dependencies from source archive: ~a~%") (define (compute-inputs source-url wheel-url archive) "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return -a pair of lists, each consisting of a list of name/variable pairs, for the -propagated inputs and the native inputs, respectively. Also -return the unaltered list of upstream dependency names." - - (define (strip-argparse deps) - (remove (cut string=? "argparse" <>) deps)) - - (define (requirement->package-name/sort deps) - (map string->symbol - (sort (map python->package-name deps) string-ci<?))) - - (define process-requirements - (compose requirement->package-name/sort strip-argparse)) - +the corresponding list of <upstream-input> records." + (define (requirements->upstream-inputs deps type) + (filter-map (match-lambda + ("argparse" #f) + (name (upstream-input + (name name) + (downstream-name (python->package-name name)) + (type type)))) + (sort deps string-ci<?))) + + ;; TODO: Record version number ranges in <upstream-input>. (let ((dependencies (guess-requirements source-url wheel-url archive))) - (values (map process-requirements dependencies) - (concatenate dependencies)))) + (match dependencies + ((propagated native) + (append (requirements->upstream-inputs propagated 'propagated) + (requirements->upstream-inputs native 'native)))))) + +(define* (pypi-package-inputs pypi-package #:optional version) + "Return the list of <upstream-input> for PYPI-PACKAGE. This procedure +downloads the source and possibly the wheel of PYPI-PACKAGE." + (let* ((info (pypi-project-info pypi-package)) + (version (or version (project-info-version info))) + (dist (source-release pypi-package version)) + (source-url (distribution-url dist)) + (wheel-url (and=> (wheel-release pypi-package version) + distribution-url))) + (call-with-temporary-output-file + (lambda (archive port) + (and (url-fetch source-url archive) + (compute-inputs source-url wheel-url archive)))))) (define (find-project-url name pypi-url) "Try different project name substitution until the result is found in @@ -445,52 +470,85 @@ pypi-uri declaration in the generated package. You may need to replace ~s with a substring of the PyPI URI that identifies the package.") pypi-url name)) name))) -(define (make-pypi-sexp name version source-url wheel-url home-page synopsis - description license) - "Return the `package' s-expression for a python package with the given NAME, -VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." +(define* (pypi-package->upstream-source pypi-package #:optional version) + "Return the upstream source for the given VERSION of PYPI-PACKAGE, a +<pypi-project> record. If VERSION is omitted or #f, use the latest version." + (let* ((info (pypi-project-info pypi-package)) + (version (or version (project-info-version info))) + (dist (source-release pypi-package version)) + (source-url (distribution-url dist)) + (wheel-url (and=> (wheel-release pypi-package version) + distribution-url))) + (let ((extra-inputs (if (string-suffix? ".zip" source-url) + (list (upstream-input + (name "zip") + (downstream-name "zip") + (type 'native))) + '()))) + (upstream-source + (urls (list source-url)) + (signature-urls + (if (distribution-has-signature? dist) + (list (string-append source-url ".asc")) + #f)) + (inputs (append (pypi-package-inputs pypi-package) + extra-inputs)) + (package (project-info-name info)) + (version version))))) + +(define* (make-pypi-sexp pypi-package + #:optional (version (latest-version pypi-package))) + "Return the `package' s-expression the given VERSION of PYPI-PACKAGE, a +<pypi-project> record." (define (maybe-upstream-name name) (if (string-match ".*\\-[0-9]+" name) `((properties ,`'(("upstream-name" . ,name)))) '())) - - (call-with-temporary-output-file - (lambda (temp port) - (and (url-fetch source-url temp) - (receive (guix-dependencies upstream-dependencies) - (compute-inputs source-url wheel-url temp) - (match guix-dependencies - ((required-inputs native-inputs) - (when (string-suffix? ".zip" source-url) - (set! native-inputs (cons 'unzip native-inputs))) - (values - `(package - (name ,(python->package-name name)) - (version ,version) - (source - (origin - (method url-fetch) - (uri (pypi-uri - ,(find-project-url name source-url) - version - ;; Some packages have been released as `.zip` - ;; instead of the more common `.tar.gz`. For - ;; example, see "path-and-address". - ,@(if (string-suffix? ".zip" source-url) - '(".zip") - '()))) - (sha256 - (base32 - ,(guix-hash-url temp))))) - ,@(maybe-upstream-name name) - (build-system pyproject-build-system) - ,@(maybe-inputs required-inputs 'propagated-inputs) - ,@(maybe-inputs native-inputs 'native-inputs) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,(beautify-description description)) - (license ,(license->symbol license))) - upstream-dependencies)))))))) + + (let* ((info (pypi-project-info pypi-package)) + (name (project-info-name info)) + (source-url (and=> (source-release pypi-package version) + distribution-url)) + (sha256 (and=> (source-release pypi-package version) + distribution-sha256)) + (source (pypi-package->upstream-source pypi-package version))) + (values + `(package + (name ,(python->package-name name)) + (version ,version) + (source + (origin + (method url-fetch) + (uri (pypi-uri + ,(find-project-url name source-url) + version + ;; Some packages have been released as `.zip` + ;; instead of the more common `.tar.gz`. For + ;; example, see "path-and-address". + ,@(if (string-suffix? ".zip" source-url) + '(".zip") + '()))) + (sha256 (base32 + ,(and=> (or sha256 + (let* ((port (http-fetch source-url)) + (hash (port-sha256 port))) + (close-port port) + hash)) + bytevector->nix-base32-string))))) + ,@(maybe-upstream-name name) + (build-system pyproject-build-system) + ,@(maybe-inputs (upstream-source-propagated-inputs source) + 'propagated-inputs) + ,@(maybe-inputs (upstream-source-native-inputs source) + 'native-inputs) + (home-page ,(project-info-home-page info)) + (synopsis ,(project-info-summary info)) + (description ,(beautify-description + (project-info-summary info))) + (license ,(license->symbol + (string->license + (project-info-license info))))) + (map upstream-input-name (upstream-source-inputs source))))) (define pypi->guix-package (memoize @@ -520,16 +578,7 @@ package is available on PyPI, but only as a \"wheel\" containing binaries, not source. To build it from source, refer to the upstream repository at @uref{~a}.") url)))))))))))) - (make-pypi-sexp (project-info-name info) version - (and=> (source-release project version) - distribution-url) - (and=> (wheel-release project version) - distribution-url) - (project-info-home-page info) - (project-info-summary info) - (project-info-summary info) - (string->license - (project-info-license info)))) + (make-pypi-sexp project version)) (values #f '())))))) (define* (pypi-recursive-import package-name #:optional version) @@ -566,21 +615,7 @@ include a VERSION string to fetch a specific version." (pypi-package (pypi-fetch pypi-name))) (and pypi-package (guard (c ((missing-source-error? c) #f)) - (let* ((info (pypi-project-info pypi-package)) - (version (or version (project-info-version info))) - (dist (source-release pypi-package version)) - (url (distribution-url dist))) - (upstream-source - (urls (list url)) - (signature-urls - (if (distribution-has-signature? dist) - (list (string-append url ".asc")) - #f)) - (input-changes - (changed-inputs package - (pypi->guix-package pypi-name #:version version))) - (package (package-name package)) - (version version))))))) + (pypi-package->upstream-source pypi-package version))))) (define %pypi-updater (upstream-updater diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index f98b86c334..f8b2726591 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-35) #:use-module (guix import json) #:use-module (guix import hackage) + #:autoload (guix import cabal) (eval-cabal) #:use-module (guix import utils) #:use-module (guix memoization) #:use-module (guix packages) @@ -157,15 +158,13 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (warning (G_ "failed to parse ~a~%") (hackage-cabal-url hackage-name)) #f) - (_ (let ((url (hackage-source-url hackage-name version))) + (_ (let ((url (hackage-source-url hackage-name version)) + (cabal (eval-cabal (hackage-fetch hackage-name) '()))) (upstream-source (package (package-name pkg)) (version version) (urls (list url)) - (input-changes - (changed-inputs - pkg - (stackage->guix-package hackage-name #:packages (packages)))))))))))) + (inputs (cabal-package-inputs cabal)))))))))) (define (stackage-lts-package? package) "Return whether PACKAGE is available on the default Stackage LTS release." diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index bfa6269aa3..d838a4aca2 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -404,7 +404,7 @@ warn about packages that have no matching updater." (('remove 'propagated) (info loc (G_ "~a: consider removing this propagated input: ~a~%") name change-name)))) - (upstream-source-input-changes source)) + (changed-inputs package source)) (let ((hash (file-hash* output))) (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ diff --git a/guix/upstream.scm b/guix/upstream.scm index aac501c466..52f9333878 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> @@ -55,7 +55,20 @@ upstream-source-urls upstream-source-signature-urls upstream-source-archive-types - upstream-source-input-changes + upstream-source-inputs + + upstream-input-type-predicate + upstream-source-regular-inputs + upstream-source-native-inputs + upstream-source-propagated-inputs + + upstream-input + upstream-input? + upstream-input-name + upstream-input-downstream-name + upstream-input-type + upstream-input-min-version + upstream-input-max-version url-predicate url-prefix-predicate @@ -102,8 +115,40 @@ (urls upstream-source-urls) ;list of strings|git-reference (signature-urls upstream-source-signature-urls ;#f | list of strings (default #f)) - (input-changes upstream-source-input-changes - (default '()) (thunked))) + (inputs upstream-source-inputs ;#f | list of <upstream-input> + (delayed) (default #f))) ;delayed because optional and costly + +;; Representation of a dependency as expressed by upstream. +(define-record-type* <upstream-input> + upstream-input make-upstream-input + upstream-input? + (name upstream-input-name) ;upstream package name + (downstream-name upstream-input-downstream-name) ;Guix package name + (type upstream-input-type ;'regular | 'native | 'propagated + (default 'regular)) + (min-version upstream-input-min-version + (default 'any)) + (max-version upstream-input-max-version + (default 'any))) + +(define (upstream-input-type-predicate type) + "Return a predicate that returns true when passed an <upstream-input> record +of the given TYPE (a symbol such as 'propagated)." + (lambda (source) + (eq? type (upstream-input-type source)))) + +(define (input-type-filter type) + "Return a procedure that, given an <upstream-source>, returns the subset of +its inputs that have the given TYPE (a symbol such as 'native)." + (lambda (source) + "Return the subset of inputs of SOURCE that have the given TYPE." + (filter (lambda (input) + (eq? type (upstream-input-type input))) + (upstream-source-inputs source)))) + +(define upstream-source-regular-inputs (input-type-filter 'regular)) +(define upstream-source-native-inputs (input-type-filter 'native)) +(define upstream-source-propagated-inputs (input-type-filter 'propagated)) ;; Representation of an upstream input change. (define-record-type* <upstream-input-change> @@ -113,67 +158,55 @@ (type upstream-input-change-type) ;symbol: regular | native | propagated (action upstream-input-change-action)) ;symbol: add | remove -(define (changed-inputs package package-sexp) - "Return a list of input changes for PACKAGE based on the newly imported -S-expression PACKAGE-SEXP." - (match package-sexp - ((and expr ('package fields ...)) - (let* ((input->name (match-lambda ((name pkg . out) name))) - (new-regular - (match expr - ((path *** ('inputs - ('quasiquote ((label ('unquote sym)) ...)))) label) - ((path *** ('inputs - ('list sym ...))) (map symbol->string sym)) - (_ '()))) - (new-native - (match expr - ((path *** ('native-inputs - ('quasiquote ((label ('unquote sym)) ...)))) label) - ((path *** ('native-inputs - ('list sym ...))) (map symbol->string sym)) - (_ '()))) - (new-propagated - (match expr - ((path *** ('propagated-inputs - ('quasiquote ((label ('unquote sym)) ...)))) label) - ((path *** ('propagated-inputs - ('list sym ...))) (map symbol->string sym)) - (_ '()))) - (current-regular - (map input->name (package-inputs package))) - (current-native - (map input->name (package-native-inputs package))) - (current-propagated - (map input->name (package-propagated-inputs package)))) - (append-map - (match-lambda - ((action type names) - (map (lambda (name) - (upstream-input-change - (name name) - (type type) - (action action))) - names))) - `((add regular - ,(lset-difference equal? - new-regular current-regular)) - (remove regular - ,(lset-difference equal? - current-regular new-regular)) - (add native - ,(lset-difference equal? - new-native current-native)) - (remove native - ,(lset-difference equal? - current-native new-native)) - (add propagated - ,(lset-difference equal? - new-propagated current-propagated)) - (remove propagated - ,(lset-difference equal? - current-propagated new-propagated)))))) - (_ '()))) +(define (changed-inputs package source) + "Return a list of input changes for PACKAGE compared to the 'inputs' field +of SOURCE, an <upstream-source> record." + (define input->name + (match-lambda + ((label (? package? pkg) . out) (package-name pkg)) + (_ #f))) + + (if (upstream-source-inputs source) + (let* ((new-regular (map upstream-input-downstream-name + (upstream-source-regular-inputs source))) + (new-native (map upstream-input-downstream-name + (upstream-source-native-inputs source))) + (new-propagated (map upstream-input-downstream-name + (upstream-source-propagated-inputs source))) + (current-regular + (filter-map input->name (package-inputs package))) + (current-native + (filter-map input->name (package-native-inputs package))) + (current-propagated + (filter-map input->name (package-propagated-inputs package)))) + (append-map + (match-lambda + ((action type names) + (map (lambda (name) + (upstream-input-change + (name name) + (type type) + (action action))) + names))) + `((add regular + ,(lset-difference equal? + new-regular current-regular)) + (remove regular + ,(lset-difference equal? + current-regular new-regular)) + (add native + ,(lset-difference equal? + new-native current-native)) + (remove native + ,(lset-difference equal? + current-native new-native)) + (add propagated + ,(lset-difference equal? + new-propagated current-propagated)) + (remove propagated + ,(lset-difference equal? + current-propagated new-propagated))))) + '())) (define* (url-predicate matching-url?) "Return a predicate that returns true when passed a package whose source is diff --git a/tests/pypi.scm b/tests/pypi.scm index 497744511f..f3b2771f4b 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -25,9 +25,12 @@ #:use-module (guix base32) #:use-module (guix memoization) #:use-module (guix utils) + #:use-module ((guix base16) #:select (base16-string->bytevector)) + #:use-module (guix upstream) #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module (guix tests http) + #:use-module ((guix download) #:select (url-fetch)) #:use-module (guix build-system python) #:use-module ((guix build utils) #:select (delete-file-recursively @@ -43,6 +46,12 @@ #:use-module (ice-9 match) #:use-module (ice-9 optargs)) +(define default-sha256 + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa") +(define default-sha256/base32 + (bytevector->nix-base32-string + (base16-string->bytevector default-sha256))) + (define* (foo-json #:key (name "foo") (name-in-url #f)) "Create a JSON description of an example pypi package, named @var{name}, optionally using a different @var{name in its URL}." @@ -65,7 +74,8 @@ optionally using a different @var{name in its URL}." ((url . ,(format #f "~a/~a-1.0.0.tar.gz" (%local-url #:path "") (or name-in-url name))) - (packagetype . "sdist")) + (packagetype . "sdist") + (digests . (("sha256" . ,default-sha256)))) ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl" (%local-url #:path "") (or name-in-url name))) @@ -308,9 +318,7 @@ files specified by SPECS. Return its file name." ('synopsis "summary") ('description "summary") ('license 'license:lgpl2.0)) - (and (string=? (bytevector->nix-base32-string - (file-sha256 tarball)) - hash) + (and (string=? default-sha256/base32 hash) (equal? (pypi->guix-package "foo" #:version "1.0.0") (pypi->guix-package "foo")) (guard (c ((error? c) #t)) @@ -352,8 +360,7 @@ to make sure we're testing wheels")))) ('synopsis "summary") ('description "summary") ('license 'license:lgpl2.0)) - (string=? (bytevector->nix-base32-string (file-sha256 tarball)) - hash)) + (string=? default-sha256/base32 hash)) (x (pk 'fail x #f)))))) @@ -382,8 +389,7 @@ to make sure we're testing wheels")))) ('synopsis "summary") ('description "summary") ('license 'license:lgpl2.0)) - (string=? (bytevector->nix-base32-string (file-sha256 tarball)) - hash)) + (string=? default-sha256/base32 hash)) (x (pk 'fail x #f)))))) @@ -414,11 +420,47 @@ to make sure we're testing wheels")))) ('synopsis "summary") ('description "summary") ('license 'license:lgpl2.0)) - (string=? (bytevector->nix-base32-string (file-sha256 tarball)) - hash)) + (string=? default-sha256/base32 hash)) (x (pk 'fail x #f)))))) +(test-equal "package-latest-release" + (list '("foo-1.0.0.tar.gz") + '("foo-1.0.0.tar.gz.asc") + (list (upstream-input + (name "bar") + (downstream-name "python-bar") + (type 'propagated)) + (upstream-input + (name "foo") + (downstream-name "python-foo") + (type 'propagated)) + (upstream-input + (name "pytest") + (downstream-name "python-pytest") + (type 'native)))) + (let ((tarball (pypi-tarball + "foo-1.0.0" + `(("src/bizarre.egg-info/requires.txt" + ,test-requires.txt))))) + (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball)) + ("/foo-1.0.0-py2.py3-none-any.whl" 404 "") + ("/foo/json" 200 ,(lambda (port) + (display (foo-json) port)))) + (define source + (package-latest-release + (dummy-package "python-foo" + (version "0.1.2") + (source (dummy-origin + (method url-fetch) + (uri (pypi-uri "foo" version)))) + (build-system python-build-system)) + (list %pypi-updater))) + + (list (map basename (upstream-source-urls source)) + (map basename (upstream-source-signature-urls source)) + (upstream-source-inputs source))))) + (test-end "pypi") (delete-file-recursively sample-directory) diff --git a/tests/upstream.scm b/tests/upstream.scm index 9aacb77229..0792ebd5d0 100644 --- a/tests/upstream.scm +++ b/tests/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -78,69 +78,29 @@ (description "test") (license license:gpl3+))) -(define test-package-sexp - '(package - (name "test") - (version "2.10") - (source (origin - (method url-fetch) - (uri (string-append "mirror://gnu/hello/hello-" version - ".tar.gz")) - (sha256 - (base32 - "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))) - (build-system gnu-build-system) - (inputs - `(("hello" ,hello))) - (native-inputs - `(("sed" ,sed) - ("tar" ,tar))) - (propagated-inputs - `(("grep" ,grep))) - (home-page "http://localhost") - (synopsis "test") - (description "test") - (license license:gpl3+))) - (test-equal "changed-inputs returns no changes" '() - (changed-inputs test-package test-package-sexp)) - -(test-assert "changed-inputs returns changes to labelled input list" - (let ((changes (changed-inputs - (package - (inherit test-package) - (inputs `(("hello" ,hello) - ("sed" ,sed)))) - test-package-sexp))) - (match changes - ;; Exactly one change - (((? upstream-input-change? item)) - (and (equal? (upstream-input-change-type item) - 'regular) - (equal? (upstream-input-change-action item) - 'remove) - (string=? (upstream-input-change-name item) - "sed"))) - (else (pk else #false))))) - -(test-assert "changed-inputs returns changes to all labelled input lists" - (let ((changes (changed-inputs - (package - (inherit test-package) - (inputs '()) - (native-inputs '()) - (propagated-inputs '())) - test-package-sexp))) - (match changes - (((? upstream-input-change? items) ...) - (and (equal? (map upstream-input-change-type items) - '(regular native native propagated)) - (equal? (map upstream-input-change-action items) - '(add add add add)) - (equal? (map upstream-input-change-name items) - '("hello" "sed" "tar" "grep")))) - (else (pk else #false))))) + (changed-inputs test-package + (upstream-source + (package "test") + (version "1") + (urls '()) + (inputs + (let ((->input + (lambda (type) + (match-lambda + ((label _) + (upstream-input + (name label) + (downstream-name label) + (type type))))))) + (append (map (->input 'regular) + (package-inputs test-package)) + (map (->input 'native) + (package-native-inputs test-package)) + (map (->input 'propagated) + (package-propagated-inputs + test-package)))))))) (define test-new-package (package @@ -152,35 +112,20 @@ (propagated-inputs (list grep)))) -(define test-new-package-sexp - '(package - (name "test") - (version "2.10") - (source (origin - (method url-fetch) - (uri (string-append "mirror://gnu/hello/hello-" version - ".tar.gz")) - (sha256 - (base32 - "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))) - (build-system gnu-build-system) - (inputs - (list hello)) - (native-inputs - (list sed tar)) - (propagated-inputs - (list grep)) - (home-page "http://localhost") - (synopsis "test") - (description "test") - (license license:gpl3+))) - (test-assert "changed-inputs returns changes to plain input list" (let ((changes (changed-inputs (package (inherit test-new-package) - (inputs (list hello sed))) - test-new-package-sexp))) + (inputs (list hello sed)) + (native-inputs '()) + (propagated-inputs '())) + (upstream-source + (package "test") + (version "1") + (urls '()) + (inputs (list (upstream-input + (name "hello") + (downstream-name name)))))))) (match changes ;; Exactly one change (((? upstream-input-change? item)) @@ -199,7 +144,26 @@ (inputs '()) (native-inputs '()) (propagated-inputs '())) - test-new-package-sexp))) + (upstream-source + (package "test") + (version "1") + (urls '()) + (inputs (list (upstream-input + (name "hello") + (downstream-name name) + (type 'regular)) + (upstream-input + (name "sed") + (downstream-name name) + (type 'native)) + (upstream-input + (name "tar") + (downstream-name name) + (type 'native)) + (upstream-input + (name "grep") + (downstream-name name) + (type 'propagated)))))))) (match changes (((? upstream-input-change? items) ...) (and (equal? (map upstream-input-change-type items) |