@@ -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>
@@ -174,14 +174,16 @@ (define (format-inputs names)
(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 +522,29 @@ (define (directory-needs-pkg-config? dir)
"(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 +558,75 @@ (define (source->dependencies source 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)))))
+ (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))))
(define* (description->package repository meta #:key (license-prefix identity)
(download-source download))
@@ -556,11 +641,6 @@ (define* (description->package repository meta #:key (license-prefix identity)
((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 +652,16 @@ (define* (description->package repository meta #:key (license-prefix identity)
(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 +707,18 @@ (define* (description->package repository meta #:key (license-prefix identity)
`((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 +737,10 @@ (define* (description->package repository meta #:key (license-prefix identity)
(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 +825,7 @@ (define* (latest-cran-release pkg #:key (version #f))
(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 +847,9 @@ (define* (latest-bioconductor-release pkg #:key (version #f))
(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."
@@ -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 @@ (define-module (guix import hackage)
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 @@ (define (filter-dependencies dependencies own-names)
(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 @@ (define* (hackage-module->sexp cabal cabal-hash
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 @@ (define* (hackage-module->sexp cabal cabal-hash
"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)
@@ -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 @@ (define-json-mapping <distribution> make-distribution distribution?
(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 @@ (define (maybe-inputs package-inputs input-type)
(()
'())
((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 @@ (define (guess-requirements source-url wheel-url archive)
(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 @@ (define (find-project-url name pypi-url)
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 @@ (define pypi->guix-package
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 @@ (define* (import-release package #:key (version #f))
(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
@@ -29,6 +29,7 @@ (define-module (guix import stackage)
#: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 @@ (define latest-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."
@@ -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>
@@ -401,7 +401,7 @@ (define* (update-package store package version updaters
(('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 \
@@ -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 @@ (define-module (guix upstream)
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 @@ (define-record-type* <upstream-source>
(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 @@ (define-record-type* <upstream-input-change>
(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
@@ -119,7 +119,7 @@ (define simple-alist
('build-system 'r-build-system)
('inputs ('list 'cairo))
('propagated-inputs
- ('list 'r-bh 'r-proto 'r-rcpp 'r-scales))
+ ('list 'r-bh 'r-rcpp 'r-proto 'r-scales))
('home-page "http://gnu.org/s/my-example")
('synopsis "Example package")
('description
@@ -25,9 +25,12 @@ (define-module (test-pypi)
#: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 @@ (define-module (test-pypi)
#: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 @@ (define* (foo-json #:key (name "foo") (name-in-url #f))
((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 @@ (define-syntax-rule (with-pypi responses body ...)
('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 @@ (define-syntax-rule (with-pypi responses body ...)
('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 @@ (define-syntax-rule (with-pypi responses body ...)
('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 @@ (define-syntax-rule (with-pypi responses body ...)
('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)
@@ -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 @@ (define test-package
(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 @@ (define test-new-package
(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 @@ (define test-new-package-sexp
(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)
Returning the expected list of inputs rather than changes relative to the current package definition is less ambiguous and offers more possibilities for further processing. * guix/upstream.scm (<upstream-source>)[input-changes]: Remove. [inputs]: New field. (<upstream-input>): New record type. * guix/upstream.scm (upstream-input-type-predicate) (input-type-filter, upstream-source-regular-inputs) (upstream-source-native-inputs, upstream-source-propagated-inputs): New procedures. (changed-inputs): Expect an <upstream-source> as its second argument. Adjust accordingly. * guix/import/pypi.scm (distribution-sha256): New procedure. (maybe-inputs): Expect a list of <upstream-input>. (compute-inputs): Rewrite to return a list of <upstream-input>. (pypi-package-inputs, pypi-package->upstream-source): New procedures. (make-pypi-sexp): Use it. * guix/import/stackage.scm (latest-lts-release): Define 'cabal'. Replace 'input-changes' field by 'inputs'. * guix/scripts/refresh.scm (update-package): Use 'changed-inputs' instead of 'upstream-source-input-changes'. * tests/cran.scm ("description->package"): Adjust order of inputs. * tests/pypi.scm (default-sha256, default-sha256/base32): New variables. (foo-json): Add 'digests' entry. ("pypi->guix-package, no wheel"): Check HASH against DEFAULT-SHA256/BASE32. ("pypi->guix-package, wheels"): Likewise. ("pypi->guix-package, no usable requirement file."): Likewise. ("pypi->guix-package, package name contains \"-\" followed by digits"): Likewise. ("package-latest-release"): New test. * tests/upstream.scm (test-package-sexp): Remove. ("changed-inputs returns no changes"): Rewrite to use <upstream-source>. (test-new-package-sexp): Remove. ("changed-inputs returns changes to plain input list"): Rewrite. ("changed-inputs returns changes to all plain input lists"): Likewise. ("changed-inputs returns changes to labelled input list") ("changed-inputs returns changes to all labelled input lists"): Remove. * guix/import/cran.scm (maybe-inputs): Expect PACKAGE-INPUTS to be a list of <upstream-input>. (source-dir->dependencies): Return a list of <upstream-input>. (vignette-builders): Likewise. (uri-helper, cran-package-source-url) (cran-package-propagated-inputs, cran-package-inputs): New procedures. (description->package): Use them instead of local definitions. (latest-cran-release): Replace 'input-changes' field by 'inputs'. (latest-bioconductor-release): Likewise. * guix/import/hackage.scm (cabal-package-inputs): New procedure. (hackage-module->sexp): Use it. [maybe-inputs]: Expect a list of <upstream-input>. --- guix/import/cran.scm | 180 +++++++++++++++++++++++----------- guix/import/hackage.scm | 90 ++++++++++------- guix/import/pypi.scm | 207 +++++++++++++++++++++++---------------- guix/import/stackage.scm | 9 +- guix/scripts/refresh.scm | 4 +- guix/upstream.scm | 163 ++++++++++++++++++------------ tests/cran.scm | 2 +- tests/pypi.scm | 62 ++++++++++-- tests/upstream.scm | 140 ++++++++++---------------- 9 files changed, 508 insertions(+), 349 deletions(-)