TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

upstream: Replace 'input-changes' field by 'inputs'. 

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.
(format-inputs): Remove.
* guix/import/hackage.scm (cabal-package-inputs): New procedure.
(hackage-module->sexp): Use it.
[maybe-inputs]: Expect a list of <upstream-input>.
This commit is contained in:
Ludovic Courtès 2023-05-15 22:37:25 +02:00
parent db10a4a2ae
commit e6223017d9
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
8 changed files with 510 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
guix/import/cran.scm
View File

@ -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."

90
guix/import/hackage.scm
View File

@ -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)

205
guix/import/pypi.scm
View File

@ -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

9
guix/import/stackage.scm
View File

@ -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."

4
guix/scripts/refresh.scm
View File

@ -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 \

163
guix/upstream.scm
View File

@ -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

62
tests/pypi.scm
View File

@ -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)

140
tests/upstream.scm
View File

@ -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)