diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/cran.scm | 154 | ||||
| -rw-r--r-- | guix/import/crate.scm | 8 | ||||
| -rw-r--r-- | guix/import/egg.scm | 51 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 84 | ||||
| -rw-r--r-- | guix/import/gem.scm | 8 | ||||
| -rw-r--r-- | guix/import/git.scm | 22 | ||||
| -rw-r--r-- | guix/import/github.scm | 52 | ||||
| -rw-r--r-- | guix/import/gnu.scm | 3 | ||||
| -rw-r--r-- | guix/import/go.scm | 91 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 31 | ||||
| -rw-r--r-- | guix/import/minetest.scm | 74 | ||||
| -rw-r--r-- | guix/import/opam.scm | 25 | ||||
| -rw-r--r-- | guix/import/print.scm | 110 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 82 | ||||
| -rw-r--r-- | guix/import/stackage.scm | 112 | ||||
| -rw-r--r-- | guix/import/texlive.scm | 307 | ||||
| -rw-r--r-- | guix/import/utils.scm | 17 |
17 files changed, 746 insertions, 485 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index f649928c5a..7a73c11382 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,9 +35,10 @@ #:use-module (web uri) #:use-module (guix memoization) #:use-module (guix http-client) - #:use-module (gcrypt hash) + #:use-module (guix diagnostics) + #:use-module (guix hash) + #:use-module (guix i18n) #:use-module (guix store) - #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) @@ -135,9 +137,9 @@ (map (lambda (name) (case (%input-style) ((specification) - (list name (list 'unquote (list 'specification->package name)))) + `(specification->package ,name)) (else - (list name (list 'unquote (string->symbol name)))))) + (string->symbol name)))) (sort names string-ci<?))) (define* (maybe-inputs package-inputs #:optional (type 'inputs)) @@ -147,15 +149,15 @@ package definition." (() '()) ((package-inputs ...) - `((,type (,'quasiquote ,(format-inputs package-inputs))))))) + `((,type (list ,@(format-inputs package-inputs))))))) (define %cran-url "https://cran.r-project.org/web/packages/") (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.13. Bioconductor packages should be +;; The latest Bioconductor release is 3.14. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.13") +(define %bioconductor-version "3.14") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -171,11 +173,11 @@ package definition." release." (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve list of packages from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) + (warning (G_ "failed to retrieve list of packages \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) #f)) ;; Split the big list on empty lines, then turn each chunk into an ;; alist of attributes. @@ -194,17 +196,6 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) -;; XXX taken from (guix scripts hash) -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - ;; Little helper to download URLs only once. (define download (memoize @@ -227,27 +218,61 @@ bioconductor package NAME, or #F if the package is unknown." (let ((store-directory (add-to-store store (basename url) #t "sha256" dir))) (values store-directory changeset))))))) - (else (download-to-store store url))))))) + (else + (match url + ((? string?) + (download-to-store store url)) + ((urls ...) + ;; Try all the URLs. A use case where this is useful is when one + ;; of the URLs is the /Archive CRAN URL. + (any (cut download-to-store store <>) urls))))))))) + +(define (fetch-description-from-tarball url) + "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and +return the resulting alist." + (match (download url) + (#f #f) + (tarball + (call-with-temporary-directory + (lambda (dir) + (parameterize ((current-error-port (%make-void-port "rw+")) + (current-output-port (%make-void-port "rw+"))) + (and (zero? (system* "tar" "--wildcards" "-x" + "--strip-components=1" + "-C" dir + "-f" tarball "*/DESCRIPTION")) + (description->alist + (call-with-input-file (string-append dir "/DESCRIPTION") + read-string))))))))) -(define (fetch-description repository name) +(define* (fetch-description repository name #:optional version) "Return an alist of the contents of the DESCRIPTION file for the R package -NAME in the given REPOSITORY, or #f in case of failure. NAME is +NAME at VERSION in the given REPOSITORY, or #f in case of failure. NAME is case-sensitive." (case repository ((cran) - (let ((url (string-append %cran-url name "/DESCRIPTION"))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (let* ((port (http-fetch url)) - (result (description->alist (read-string port)))) - (close-port port) - result)))) + (guard (c ((http-get-error? c) + (warning (G_ "failed to retrieve package information \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + ;; When VERSION is true, we have to download the tarball to get at its + ;; 'DESCRIPTION' file; only the latest one is directly accessible over + ;; HTTP. + (if version + (let ((urls (list (string-append "mirror://cran/src/contrib/" + name "_" version ".tar.gz") + (string-append "mirror://cran/src/contrib/Archive/" + name "/" + name "_" version ".tar.gz")))) + (fetch-description-from-tarball urls)) + (let* ((url (string-append %cran-url name "/DESCRIPTION")) + (port (http-fetch url)) + (result (description->alist (read-string port)))) + (close-port port) + result)))) ((bioconductor) ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, @@ -256,22 +281,13 @@ from ~s: ~a (~s)~%" (and (latest-bioconductor-package-version name) #t) (and (latest-bioconductor-package-version name 'annotation) 'annotation) (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + ;; TODO: Honor VERSION. (version (latest-bioconductor-package-version name type)) (url (car (bioconductor-uri name version type))) - (tarball (download url))) - (call-with-temporary-directory - (lambda (dir) - (parameterize ((current-error-port (%make-void-port "rw+")) - (current-output-port (%make-void-port "rw+"))) - (and (zero? (system* "tar" "--wildcards" "-x" - "--strip-components=1" - "-C" dir - "-f" tarball "*/DESCRIPTION")) - (and=> (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)) - (lambda (meta) - (if (boolean? type) meta - (cons `(bioconductor-type . ,type) meta)))))))))) + (meta (fetch-description-from-tarball url))) + (if (boolean? type) + meta + (cons `(bioconductor-type . ,type) meta)))) ((git) (and (string-prefix? "http" name) ;; Download the git repository at "NAME" @@ -437,16 +453,6 @@ reference the pkg-config tool." (define (needs-knitr? meta) (member "knitr" (listify meta "VignetteBuilder"))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file select? recursive?) - ;; Compute the hash of FILE. - (if recursive? - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (call-with-input-file file port-sha256))) - (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." @@ -484,11 +490,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((bioconductor) (list (assoc-ref meta 'bioconductor-type))) (else '()))) - ((url rest ...) url) + ((urls ...) urls) ((? string? url) url) (_ #f))))) - (git? (assoc-ref meta 'git)) - (hg? (assoc-ref meta 'hg)) + (git? (if (assoc-ref meta 'git) #true #false)) + (hg? (if (assoc-ref meta 'hg) #true #false)) (source (download source-url #:method (cond (git? 'git) (hg? 'hg) @@ -544,12 +550,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (sha256 (base32 ,(bytevector->nix-base32-string - (case repository - ((git) - (file-hash source (negate vcs-file?) #t)) - ((hg) - (file-hash source (negate vcs-file?) #t)) - (else (file-sha256 source)))))))) + (file-hash* source #:recursive? (or git? hg?))))))) ,@(if (not (and git? hg? (equal? (string-append "r-" name) (cran-guix-name name)))) @@ -591,7 +592,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:key (repo 'cran) version) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((description (fetch-description repo package-name))) + (let ((description (fetch-description repo package-name version))) (if description (description->package repo description) (case repo @@ -609,8 +610,9 @@ s-expression corresponding to that package, or #f on failure." (&message (message "couldn't find meta-data for R package"))))))))))) -(define* (cran-recursive-import package-name #:key (repo 'cran)) +(define* (cran-recursive-import package-name #:key (repo 'cran) version) (recursive-import package-name + #:version version #:repo repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 287ffd2536..c76d7e9c1a 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; @@ -79,7 +79,10 @@ (number crate-version-number "num") ;string (download-path crate-version-download-path "dl_path") ;string (readme-path crate-version-readme-path "readme_path") ;string - (license crate-version-license "license") ;string + (license crate-version-license "license" ;string | #f + (match-lambda + ('null #f) + ((? string? str) str))) (links crate-version-links)) ;alist ;; Crate dependency. Each dependency (each edge in the graph) is annotated as @@ -198,6 +201,7 @@ and LICENSE." (description ,(beautify-description description)) (license ,(match license (() #f) + (#f #f) ((license) license) (_ `(list ,@license))))))) (close-port port) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 89e7a9160d..0b88020554 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,10 +52,10 @@ ;;; ;;; The following happens under the hood: ;;; -;;; * <git://code.call-cc.org/eggs-5-latest> is a Git repository that contains -;;; the latest version of all CHICKEN eggs. We look clone this repository -;;; and retrieve the latest version number, and the PACKAGE.egg file, which -;;; contains a list of lists containing metadata about the egg. +;;; * <git://code.call-cc.org/eggs-5-all> is a Git repository that contains +;;; all versions of all CHICKEN eggs. We look clone this repository and, by +;;; default, retrieve the latest version number, and the PACKAGE.egg file, +;;; which contains a list of lists containing metadata about the egg. ;;; ;;; * All the eggs are stored as tarballs at ;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for @@ -96,7 +97,7 @@ NAME." (define (eggs-repository) "Update or fetch the latest version of the eggs repository and return the path to the repository." - (let* ((url "git://code.call-cc.org/eggs-5-latest") + (let* ((url "git://code.call-cc.org/eggs-5-all") (directory commit _ (update-cached-checkout url))) directory)) @@ -112,12 +113,13 @@ to the repository." (last directory) #f))) -(define* (egg-metadata name #:optional file) - "Return the package metadata file for the egg NAME, or if FILE is specified, -return the package metadata in FILE." +(define* (egg-metadata name #:key (version #f) (file #f)) + "Return the package metadata file for the egg NAME at version VERSION, or if +FILE is specified, return the package metadata in FILE." (call-with-input-file (or file (string-append (egg-directory name) "/" - (find-latest-version name) + (or version + (find-latest-version name)) "/" name ".egg")) read)) @@ -173,10 +175,11 @@ return the package metadata in FILE." ;;; Egg importer. ;;; -(define* (egg->guix-package name #:key (file #f) (source #f)) - "Import a CHICKEN egg called NAME from either the given .egg FILE, or from -the latest NAME metadata downloaded from the official repository if FILE is #f. -Return a <package> record or #f on failure. +(define* (egg->guix-package name version #:key (file #f) (source #f)) + "Import a CHICKEN egg called NAME from either the given .egg FILE, or from the +latest NAME metadata downloaded from the official repository if FILE is #f. +Return a <package> record or #f on failure. If VERSION is specified, import +the particular version from the egg repository. SOURCE is a ``file-like'' object containing the source code corresponding to the egg. If SOURCE is not specified, the latest tarball for egg NAME will be @@ -186,8 +189,8 @@ Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg locally. Note that if FILE and SOURCE are specified, recursive import will not work." (define egg-content (if file - (egg-metadata name file) - (egg-metadata name))) + (egg-metadata name #:file file) + (egg-metadata name #:version version))) (if (not egg-content) (values #f '()) ; egg doesn't exist (let* ((version* (or (assoc-ref egg-content 'version) @@ -247,12 +250,9 @@ not work." (let ((name (prettify-name (extract-name name)))) ;; Dependencies are sometimes specified as symbols and sometimes ;; as strings - (list (string-append (if system? "" package-name-prefix) - name) - (list 'unquote - (string->symbol (string-append - (if system? "" package-name-prefix) - name)))))) + (string->symbol (string-append + (if system? "" package-name-prefix) + name)))) (define egg-propagated-inputs (let ((dependencies (assoc-ref egg-content 'dependencies))) @@ -291,7 +291,7 @@ not work." '()) ((inputs ...) (list (list input-type - (list 'quasiquote inputs)))))) + `(list ,@inputs)))))) (values `(package @@ -319,17 +319,18 @@ not work." (license ,egg-licenses)) (filter (lambda (name) (not (member name '("srfi-4")))) - (map (compose guix-name->egg-name first) + (map (compose guix-name->egg-name symbol->string) (append egg-propagated-inputs egg-native-inputs))))))) (define egg->guix-package/m ;memoized variant (memoize egg->guix-package)) -(define (egg-recursive-import package-name) +(define* (egg-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package (lambda* (name #:key version repo) - (egg->guix-package/m name)) + (egg->guix-package/m name version)) #:guix-name egg-name->guix-name)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 96ebc17af1..ea77a7c244 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,15 +38,17 @@ #:use-module (guix import utils) #:use-module (guix http-client) #:use-module (guix git) + #:use-module (guix hash) #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix store) #:use-module (guix ui) - #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (guix memoization) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package + guix-package->elpa-name %elpa-updater elpa-recursive-import)) @@ -228,27 +231,6 @@ keywords to values." (close-port port) (data->recipe (cons ':name data)))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file select? recursive?) - ;; Compute the hash of FILE. - (if recursive? - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (call-with-input-file file port-sha256))) - -;; XXX taken from (guix scripts hash) -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - (define (git-repository->origin recipe url) "Fetch origin details from the Git repository at URL for the provided MELPA RECIPE." @@ -270,7 +252,7 @@ RECIPE." (sha256 (base32 ,(bytevector->nix-base32-string - (file-hash directory (negate vcs-file?) #t))))))) + (file-hash* directory #:recursive? #true))))))) (define* (melpa-recipe->origin recipe) "Fetch origin details from the MELPA recipe and associated repository for @@ -337,9 +319,10 @@ the package named PACKAGE-NAME." type '<elpa-package>'." (define melpa-recipe - (if (eq? repo 'melpa) - (package-name->melpa-recipe (elpa-package-name pkg)) - #f)) + ;; XXX: Call 'identity' to work around a Guile 3.0.[5-7] compiler bug: + ;; <https://bugs.gnu.org/48368>. + (and (eq? (identity repo) 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)))) (define name (elpa-package-name pkg)) @@ -352,9 +335,7 @@ type '<elpa-package>'." (elpa-package-inputs pkg)))) (define dependencies - (map (lambda (n) - (let ((new-n (elpa-name->package-name n))) - (list new-n (list 'unquote (string->symbol new-n))))) + (map (compose string->symbol elpa-name->package-name) dependencies-names)) (define (maybe-inputs input-type inputs) @@ -362,8 +343,7 @@ type '<elpa-package>'." (() '()) ((inputs ...) - (list (list input-type - (list 'quasiquote inputs)))))) + (list (list input-type `(list ,@inputs)))))) (define melpa-source (melpa-recipe->origin melpa-recipe)) @@ -381,7 +361,8 @@ type '<elpa-package>'." (sha256 (base32 ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) + (bytevector->nix-base32-string + (file-hash* tarball #:recursive? #false)) "failed to download package"))))))) (build-system emacs-build-system) ,@(maybe-inputs 'propagated-inputs dependencies) @@ -390,7 +371,7 @@ type '<elpa-package>'." '()) (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) + (description ,(beautify-description (elpa-package-description pkg))) (license ,license)) dependencies-names)) @@ -414,14 +395,18 @@ type '<elpa-package>'." ;;; Updates. ;;; +(define (guix-package->elpa-name package) + "Given a Guix package, PACKAGE, return the upstream name on ELPA." + (or (and=> (package-properties package) + (cut assq-ref <> 'upstream-name)) + (if (string-prefix? "emacs-" (package-name package)) + (string-drop (package-name package) 6) + (package-name package)))) + (define (latest-release package) "Return an <upstream-release> for the latest release of PACKAGE." - (define name - (if (string-prefix? "emacs-" (package-name package)) - (string-drop (package-name package) 6) - (package-name package))) - - (define repo 'gnu) + (define name (guix-package->elpa-name package)) + (define repo (elpa-repository package)) (match (elpa-package-info name repo) (#f @@ -440,11 +425,20 @@ type '<elpa-package>'." (urls (list url)) (signature-urls (list (string-append url ".sig")))))))) -(define package-from-gnu.org? - (url-predicate (lambda (url) - (let ((uri (string->uri url))) - (and uri - (string=? (uri-host uri) "elpa.gnu.org")))))) +(define elpa-repository + (memoize + (url-predicate (lambda (url) + (let ((uri (string->uri url))) + (and uri + (cond + ((string=? (uri-host uri) "elpa.gnu.org") + 'gnu) + ((string=? (uri-host uri) "elpa.nongnu.org") + 'nongnu) + (else #f)))))))) + +(define (package-from-elpa-repository? package) + (member (elpa-repository package) '(gnu nongnu))) (define %elpa-updater ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org @@ -452,7 +446,7 @@ type '<elpa-package>'." (upstream-updater (name 'elpa) (description "Updater for ELPA packages") - (pred package-from-gnu.org?) + (pred package-from-elpa-repository?) (latest latest-release))) (define elpa-guix-name (cut guix-name "emacs-" <>)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 418d716be6..0e5bb7e635 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -110,12 +111,7 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." ,@(if (null? dependencies) '() `((propagated-inputs - (,'quasiquote - ,(map (lambda (name) - `(,name - (,'unquote - ,(string->symbol name)))) - dependencies))))) + (list ,@(map string->symbol dependencies))))) (synopsis ,synopsis) (description ,description) (home-page ,home-page) diff --git a/guix/import/git.scm b/guix/import/git.scm index 1eb219f3fe..4cf404677c 100644 --- a/guix/import/git.scm +++ b/guix/import/git.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:export (%generic-git-updater ;; For tests. @@ -172,21 +174,21 @@ repository at URL." (values version tag))))))) (define (latest-git-tag-version package) - "Given a PACKAGE, return the latest version of it, or #f if the latest version -could not be determined." + "Given a PACKAGE, return the latest version of it and the corresponding git +tag, or #false and #false if the latest version could not be determined." (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) (warning (or (package-field-location package 'source) (package-location package)) (G_ "~a for ~a~%") (condition-message c) (package-name package)) - #f) + (values #f #f)) ((eq? (exception-kind c) 'git-error) (warning (or (package-field-location package 'source) (package-location package)) (G_ "failed to fetch Git repository for ~a~%") (package-name package)) - #f)) + (values #f #f))) (let* ((source (package-source package)) (url (git-reference-url (origin-uri source))) (property (cute assq-ref (package-properties package) <>))) @@ -208,14 +210,16 @@ could not be determined." "Return an <upstream-source> for the latest release of PACKAGE." (let* ((name (package-name package)) (old-version (package-version package)) - (url (git-reference-url (origin-uri (package-source package)))) - (new-version (latest-git-tag-version package))) - - (and new-version + (old-reference (origin-uri (package-source package))) + (new-version new-version-tag (latest-git-tag-version package))) + (and new-version new-version-tag (upstream-source (package name) (version new-version) - (urls (list url)))))) + (urls (git-reference + (url (git-reference-url old-reference)) + (commit new-version-tag) + (recursive? (git-reference-recursive? old-reference)))))))) (define %generic-git-updater (upstream-updater diff --git a/guix/import/github.scm b/guix/import/github.scm index 888b148ffb..8c1898c0c5 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-71) #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix diagnostics) @@ -37,7 +39,10 @@ #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) - #:export (%github-updater)) + #:export (%github-api %github-updater)) + +;; For tests. +(define %github-api (make-parameter "https://api.github.com")) (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or @@ -148,11 +153,11 @@ tags show up in the \"Releases\" tab of the web UI. For instance, 'https://api.github.com/repos/aconchillo/guile-json/releases' returns the empty list." (define release-url - (string-append "https://api.github.com/repos/" + (string-append (%github-api) "/repos/" (github-user-slash-repository url) "/releases")) (define tag-url - (string-append "https://api.github.com/repos/" + (string-append (%github-api) "/repos/" (github-user-slash-repository url) "/tags")) @@ -181,12 +186,15 @@ empty list." (x x))))) (define (latest-released-version url package-name) - "Return a string of the newest released version name given a string URL like + "Return the newest released version and its tag given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of -the package e.g. 'bedtools2'. Return #f if there is no releases" +the package e.g. 'bedtools2'. Return #f (two values) if there are no +releases." (define (pre-release? x) (assoc-ref x "prerelease")) + ;; This procedure returns (version . tag) pair, or #f + ;; if RELEASE doesn't seyem to correspond to a version. (define (release->version release) (let ((tag (or (assoc-ref release "tag_name") ;a "release" (assoc-ref release "name"))) ;a tag @@ -197,22 +205,22 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" ((and (< name-length (string-length tag)) (string=? (string-append package-name "-") (substring tag 0 (+ name-length 1)))) - (substring tag (+ name-length 1))) + (cons (substring tag (+ name-length 1)) tag)) ;; some tags start with a "v" e.g. "v0.25.0" ;; or with the word "version" e.g. "version.2.1" ;; where some are just the version number ((string-prefix? "version" tag) - (if (char-set-contains? char-set:digit (string-ref tag 7)) - (substring tag 7) - (substring tag 8))) + (cons (if (char-set-contains? char-set:digit (string-ref tag 7)) + (substring tag 7) + (substring tag 8)) tag)) ((string-prefix? "v" tag) - (substring tag 1)) + (cons (substring tag 1) tag)) ;; Finally, reject tags that don't start with a digit: ;; they may not represent a release. ((and (not (string-null? tag)) (char-set-contains? char-set:digit (string-ref tag 0))) - tag) + (cons tag tag)) (else #f)))) (let* ((json (and=> (fetch-releases-or-tags url) @@ -229,14 +237,14 @@ https://github.com/settings/tokens")) (match (remove pre-release? json) (() json) ; keep everything (releases releases))) - version>?) - ((latest-release . _) latest-release) - (() #f))))) + (lambda (x y) (version>? (car x) (car y)))) + (((latest-version . tag) . _) (values latest-version tag)) + (() (values #f #f)))))) (define (latest-release pkg) "Return an <upstream-source> for the latest release of PKG." - (define (origin-github-uri origin) - (match (origin-uri origin) + (define (github-uri uri) + (match uri ((? string? url) url) ;surely a github.com URL ((? download:git-reference? ref) @@ -244,14 +252,20 @@ https://github.com/settings/tokens")) ((urls ...) (find (cut string-contains <> "github.com") urls)))) - (let* ((source-uri (origin-github-uri (package-source pkg))) + (let* ((original-uri (origin-uri (package-source pkg))) + (source-uri (github-uri original-uri)) (name (package-name pkg)) - (newest-version (latest-released-version source-uri name))) + (newest-version version-tag + (latest-released-version source-uri name))) (if newest-version (upstream-source (package name) (version newest-version) - (urls (list (updated-github-url pkg newest-version)))) + (urls (if (download:git-reference? original-uri) + (download:git-reference + (inherit original-uri) + (commit version-tag)) + (list (updated-github-url pkg newest-version))))) #f))) ; On GitHub but no proper releases (define %github-updater diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 51d5b77d34..2b9b71feb0 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -100,7 +100,8 @@ download policy (see 'download-tarball' for details.)" (file-sha256 tarball)))))) (build-system gnu-build-system) (synopsis ,(gnu-package-doc-summary package)) - (description ,(gnu-package-doc-description package)) + (description ,(beautify-description + (gnu-package-doc-description package))) (home-page ,(match (gnu-package-doc-urls package) ((head . tail) (qualified-url head)))) (license find-by-yourself!))) diff --git a/guix/import/go.scm b/guix/import/go.scm index 9769b557ae..d00c13475a 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> @@ -26,6 +26,7 @@ (define-module (guix import go) #:use-module (guix build-system go) #:use-module (guix git) + #:use-module (guix hash) #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module (guix import utils) @@ -36,11 +37,11 @@ #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) #:autoload (htmlprag) (html->sxml) ;from Guile-Lib - #:autoload (guix git) (update-cached-checkout) - #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) #:autoload (guix serialization) (write-file) #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) + #:autoload (gcrypt hash) (hash-algorithm sha256) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 peg) #:use-module (ice-9 rdelim) @@ -54,6 +55,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (sxml match) #:use-module ((sxml xpath) #:renamer (lambda (s) (if (eq? 'filter s) @@ -474,7 +476,7 @@ Optionally include a VERSION string to append to the name." because goproxy servers don't currently provide all the information needed to build a package." (define (go-import->module-meta content-text) - (match (string-split content-text #\space) + (match (string-tokenize content-text char-set:graphic) ((root-path vcs repo-url) (make-module-meta root-path (string->symbol vcs) (strip-.git-suffix/maybe repo-url))))) @@ -499,25 +501,6 @@ source." goproxy (module-meta-repo-root meta-data))) -;; XXX: Copied from (guix scripts hash). -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - -;; XXX: Adapted from 'file-hash' in (guix scripts hash). -(define* (file-hash file #:optional (algorithm (hash-algorithm sha256))) - ;; Compute the hash of FILE. - (let-values (((port get-hash) (open-hash-port algorithm))) - (write-file file port #:select? (negate vcs-file?)) - (force-output port) - (get-hash))) - (define* (git-checkout-hash url reference algorithm) "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or tag." @@ -536,7 +519,7 @@ tag." (update-cached-checkout url #:ref `(tag-or-commit . ,reference))))) - (file-hash checkout algorithm))) + (file-hash* checkout #:algorithm algorithm #:recursive? #true))) (define (vcs->origin vcs-type vcs-repo-url version) "Generate the `origin' block of a package depending on what type of source @@ -588,6 +571,34 @@ control system is being used." (formatted-message (G_ "unsupported vcs type '~a' for package '~a'") vcs-type vcs-repo-url))))) +(define (strip-v-prefix version) + "Strip from VERSION the \"v\" prefix that Go uses." + (string-trim version #\v)) + +(define (ensure-v-prefix version) + "Add a \"v\" prefix to VERSION if it does not already have one." + (if (string-prefix? "v" version) + version + (string-append "v" version))) + +(define (validate-version version available-versions module-path) + "Raise an error if VERSION is not among AVAILABLE-VERSIONS, unless VERSION +is a pseudo-version. Return VERSION." + ;; Pseudo-versions do not appear in the versions list; skip the + ;; following check. + (if (or (go-pseudo-version? version) + (member version available-versions)) + version + (raise + (make-compound-condition + (formatted-message (G_ "version ~a of ~a is not available~%") + version module-path available-versions) + (condition (&fix-hint + (hint (format #f (G_ "Pick one of the following \ +available versions:~{ ~a~}.") + (map strip-v-prefix + available-versions))))))))) + (define* (go-module->guix-package module-path #:key (goproxy "https://proxy.golang.org") version @@ -596,22 +607,18 @@ control system is being used." The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. When VERSION is unspecified, the latest version available is used." (let* ((available-versions (go-module-available-versions goproxy module-path)) - (version* (or version - (go-module-version-string goproxy module-path))) ;latest - ;; Elide the "v" prefix Go uses. - (strip-v-prefix (cut string-trim <> #\v)) - ;; Pseudo-versions do not appear in the versions list; skip the - ;; following check. - (_ (unless (or (go-pseudo-version? version*) - (member version* available-versions)) - (error (format #f "error: version ~s is not available -hint: use one of the following available versions ~a\n" - version* available-versions)))) + (version* (validate-version + (or (and version (ensure-v-prefix version)) + (go-module-version-string goproxy module-path)) ;latest + available-versions + module-path)) (content (fetch-go.mod goproxy module-path version*)) (dependencies+versions (go.mod-requirements (parse-go.mod content))) (dependencies (if pin-versions? dependencies+versions (map car dependencies+versions))) + (module-path-sans-suffix + (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -631,7 +638,7 @@ hint: use one of the following available versions ~a\n" (build-system go-build-system) (arguments '(#:import-path ,module-path - ,@(if (string=? module-path root-module-path) + ,@(if (string=? module-path-sans-suffix root-module-path) '() `(#:unpack-path ,root-module-path)))) ,@(maybe-propagated-inputs @@ -645,10 +652,10 @@ hint: use one of the following available versions ~a\n" (synopsis ,synopsis) (description ,(and=> description beautify-description)) (license ,(match (list->licenses licenses) - (() #f) ;unknown license - ((license) ;a single license + (() #f) ;unknown license + ((license) ;a single license license) - ((license ...) ;a list of licenses + ((license ...) ;a list of licenses `(list ,@license))))) (if pin-versions? dependencies+versions @@ -668,12 +675,6 @@ This package and its dependencies won't be imported.~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (values #f '())) - (else - (warning (G_ "Failed to import package ~s. -reason: ~s.~%") - package-name - (exception-args c)) (values #f '()))) (apply go-module->guix-package args))))) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index f94a1e7087..b94f4169d4 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +33,7 @@ #:use-module ((guix utils) #:select (package-name->name+version canonical-newline-port)) #:use-module (guix http-client) - #:use-module ((guix import utils) #:select (factorize-uri recursive-import)) + #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) #:use-module (gcrypt hash) @@ -40,6 +41,7 @@ #:use-module (guix memoization) #:use-module (guix upstream) #:use-module (guix packages) + #:autoload (guix build-system haskell) (hackage-uri) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (%hackage-url hackage->guix-package @@ -54,8 +56,8 @@ hackage-package?)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (8.6.5). - ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5. + ;; List of libraries distributed with ghc (as of 8.10.7). + ;; Contents of …-ghc-8.10.7/lib/ghc-8.10.7 '("ghc" "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but ;; hackage-name->package-name takes this into account. @@ -67,6 +69,7 @@ "containers" "deepseq" "directory" + "exceptions" "filepath" "ghc" "ghc-boot" @@ -120,12 +123,12 @@ version is returned." (string-append package-name-prefix (string-downcase name)))) (define guix-package->hackage-name - (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*")) + (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*")) (name-rx (make-regexp "(.*)-[0-9\\.]+"))) (lambda (package) "Given a Guix package name, return the corresponding Hackage name." (let* ((source-url (and=> (package-source package) origin-uri)) - (name (match:substring (regexp-exec uri-rx source-url) 1))) + (name (match:substring (regexp-exec uri-rx source-url) 2))) (match (regexp-exec name-rx name) (#f name) (m (match:substring m 1))))))) @@ -265,14 +268,12 @@ the hash of the Cabal file." hackage-dependencies)) (define dependencies - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (map string->symbol (map hackage-name->package-name hackage-dependencies))) (define native-dependencies - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (map string->symbol (map hackage-name->package-name hackage-native-dependencies))) @@ -282,8 +283,8 @@ the hash of the Cabal file." '()) ((inputs ...) (list (list input-type - (list 'quasiquote inputs)))))) - + `(list ,@inputs)))))) + (define (maybe-arguments) (match (append (if (not include-test-dependencies?) '(#:tests? #f) @@ -302,7 +303,7 @@ the hash of the Cabal file." (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (hackage-uri ,name version)) (sha256 (base32 ,(if tarball @@ -314,7 +315,7 @@ the hash of the Cabal file." ,@(maybe-arguments) (home-page ,(cabal-package-home-page cabal)) (synopsis ,(cabal-package-synopsis cabal)) - (description ,(cabal-package-description cabal)) + (description ,(beautify-description (cabal-package-description cabal))) (license ,(string->license (cabal-package-license cabal)))) (append hackage-dependencies hackage-native-dependencies)))) @@ -352,7 +353,7 @@ respectively." #:guix-name hackage-name->package-name)) (define hackage-package? - (let ((hackage-rx (make-regexp "https?://hackage.haskell.org"))) + (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) (define (latest-release package) @@ -366,7 +367,7 @@ respectively." (hackage-cabal-url hackage-name)) #f) ((_ *** ("version" (version))) - (let ((url (hackage-source-url hackage-name version))) + (let ((url (hackage-uri hackage-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index ba86c60bfd..3b2cdcdcac 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +25,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module ((guix packages) #:prefix package:) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix ui) #:use-module (guix i18n) @@ -36,15 +38,20 @@ #:use-module (json) #:use-module (guix base32) #:use-module (guix git) + #:use-module ((guix git-download) #:prefix download:) + #:use-module (guix hash) #:use-module (guix store) #:export (%default-sort-key %contentdb-api json->package contentdb-fetch elaborate-contentdb-name + minetest-package? + latest-minetest-release minetest->guix-package minetest-recursive-import - sort-packages)) + sort-packages + %minetest-updater)) ;; The ContentDB API is documented at ;; <https://content.minetest.net>. @@ -280,14 +287,6 @@ results. The return value is a list of <package-keys> records." (with-store store (latest-repository-commit store url #:ref ref))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file) - "Compute the hash of FILE." - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port) - (force-output port) - (get-hash))) - (define (make-minetest-sexp author/name version repository commit inputs home-page synopsis description media-license license) @@ -308,15 +307,19 @@ MEDIA-LICENSE and LICENSE." ;; The git commit is not always available. ,(and commit (bytevector->nix-base32-string - (file-hash + (file-hash* (download-git-repository repository - `(commit . ,commit))))))) + `(commit . ,commit)) + ;; 'download-git-repository' already filtered out the '.git' + ;; directory. + #:select? (const #true) + #:recursive? #true))))) (file-name (git-file-name name version)))) (build-system minetest-mod-build-system) ,@(maybe-propagated-inputs (map contentdb->package-name inputs)) (home-page ,home-page) (synopsis ,(delete-cr synopsis)) - (description ,(delete-cr description)) + (description ,(beautify-description (delete-cr description))) (license ,(if (eq? media-license license) license `(list ,media-license ,license))) @@ -345,6 +348,17 @@ official Minetest forum and the Git repository (if any)." (substring title 1) title)) +(define (version-style version) + "Determine the kind of version number VERSION is -- a date, or a conventional +conventional version number." + (define dots? (->bool (string-index version #\.))) + (define hyphens? (->bool (string-index version #\-))) + (match (cons dots? hyphens?) + ((#true . #false) 'regular) ; something like "0.1" + ((#false . #false) 'regular) ; single component version number + ((#true . #true) 'regular) ; result of 'git-version' + ((#false . #true) 'date))) ; something like "2021-01-25" + ;; If the default sort key is changed, make sure to modify 'show-help' ;; in (guix scripts import minetest) appropriately as well. (define %default-sort-key "score") @@ -466,3 +480,37 @@ list of AUTHOR/NAME strings." (recursive-import author/name #:repo->guix-package minetest->guix-package* #:guix-name contentdb->package-name)) + +(define (minetest-package? pkg) + "Is PKG a Minetest mod on ContentDB?" + (and (string-prefix? "minetest-" (package:package-name pkg)) + (assq-ref (package:package-properties pkg) 'upstream-name))) + +(define (latest-minetest-release pkg) + "Return an <upstream-source> for the latest release of the package PKG, +or #false if the latest release couldn't be determined." + (define author/name + (assq-ref (package:package-properties pkg) 'upstream-name)) + (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f? + (define release (latest-release author/name)) + (define source (package:package-source pkg)) + (and contentdb-package release + (release-commit release) ; not always set + ;; Only continue if both the old and new version number are both + ;; dates or regular version numbers, as two different styles confuses + ;; the logic for determining which version is newer. + (eq? (version-style (release-version release)) + (version-style (package:package-version pkg))) + (upstream-source + (package (package:package-name pkg)) + (version (release-version release)) + (urls (download:git-reference + (url (package-repository contentdb-package)) + (commit (release-commit release))))))) + +(define %minetest-updater + (upstream-updater + (name 'minetest) + (description "Updater for Minetest packages on ContentDB") + (pred minetest-package?) + (latest latest-minetest-release))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index fe13d29f03..a6f6fe8c9f 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; ;;; This file is part of GNU Guix. @@ -230,7 +231,8 @@ path to the repository." (('list-pat . stuff) stuff) (('string-pat stuff) stuff) (('multiline-string stuff) stuff) - (('dict records ...) records)) + (('dict records ...) records) + (_ #f)) acc)))) #f file)) @@ -305,10 +307,8 @@ path to the repository." (map dependency->native-input depends))) (define (dependency-list->inputs lst) - (map - (lambda (dependency) - (list dependency (list 'unquote (string->symbol dependency)))) - (ocaml-names->guix-names lst))) + (map string->symbol + (ocaml-names->guix-names lst))) (define* (opam-fetch name #:optional (repositories-specs '("opam"))) (or (fold (lambda (repository others) @@ -318,11 +318,11 @@ path to the repository." (_ others))) #f (filter-map get-opam-repository repositories-specs)) - (leave (G_ "package '~a' not found~%") name))) + (warning (G_ "opam: package '~a' not found~%") name))) -(define* (opam->guix-package name #:key (repo '()) version) - "Import OPAM package NAME from REPOSITORIES (a list of names, URLs or local -paths, always including OPAM's official repository). Return a 'package' sexp +(define* (opam->guix-package name #:key (repo 'opam) version) + "Import OPAM package NAME from REPOSITORY (a directory name) or, if +REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." (and-let* ((with-opam (if (member "opam" repo) repo (cons "opam" repo))) (opam-file (opam-fetch name with-opam)) @@ -361,17 +361,18 @@ or #f on failure." 'ocaml-build-system)) ,@(if (null? inputs) '() - `((propagated-inputs ,(list 'quasiquote inputs)))) + `((propagated-inputs (list ,@inputs)))) ,@(if (null? native-inputs) '() - `((native-inputs ,(list 'quasiquote native-inputs)))) + `((native-inputs (list ,@native-inputs)))) ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) '() `((properties ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) + (description ,(beautify-description + (metadata-ref opam-content "description"))) (license ,(spdx-string->license (metadata-ref opam-content "license")))) (filter diff --git a/guix/import/print.scm b/guix/import/print.scm index 0310739b3a..66016145cb 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,14 +26,20 @@ #:use-module (guix build-system) #:use-module (gnu packages) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (guix import utils) #:use-module (ice-9 control) #:use-module (ice-9 match) #:export (package->code)) -;; FIXME: the quasiquoted arguments field may contain embedded package -;; objects, e.g. in #:disallowed-references; they will just be printed with -;; their usual #<package ...> representation, not as variable names. +(define (redundant-input-labels? inputs) + "Return #t if input labels in the INPUTS list are redundant." + (every (match-lambda + ((label (? package? package) . _) + (string=? label (package-name package))) + (_ #f)) + inputs)) + (define (package->code package) "Return an S-expression representing the source code that produces PACKAGE when evaluated." @@ -72,6 +79,11 @@ when evaluated." (file-type (quote ,(search-path-specification-file-type spec))) (file-pattern ,(search-path-specification-file-pattern spec)))) + (define (factorized-uri-code uri version) + (match (factorize-uri uri version) + ((? string? uri) uri) + ((factorized ...) `(string-append ,@factorized)))) + (define (source->code source version) (let ((uri (origin-uri source)) (method (origin-method source)) @@ -89,9 +101,14 @@ when evaluated." (guix hg-download) (guix svn-download))) (procedure-name method))) - (uri (string-append ,@(match (factorize-uri uri version) - ((? string? uri) (list uri)) - (factorized factorized)))) + (uri ,(if version + (match uri + ((? string? uri) + (factorized-uri-code uri version)) + ((lst ...) + `(list + ,@(map (cut factorized-uri-code <> version) uri)))) + uri)) ,(if (equal? (content-hash-algorithm hash) 'sha256) `(sha256 (base32 ,(bytevector->nix-base32-string (content-hash-value hash)))) @@ -101,24 +118,62 @@ when evaluated." ;; FIXME: in order to be able to throw away the directory prefix, ;; we just assume that the patch files can be found with ;; "search-patches". - ,@(if (null? patches) '() - `((patches (search-patches ,@(map basename patches)))))))) + ,@(cond ((null? patches) + '()) + ((every string? patches) + `((patches (search-patches ,@(map basename patches))))) + (else + `((patches (list ,@(map (match-lambda + ((? string? file) + `(search-patch ,file)) + ((? origin? origin) + (source->code origin #f))) + patches))))))))) + + (define (variable-reference module name) + ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import + ;; the individual package modules. + (list '@ module name)) + + (define (object->code obj quoted?) + (match obj + ((? package? package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (if quoted? + (list 'unquote (variable-reference module name)) + (variable-reference module name)))) + ((? origin? origin) + (let ((code (source->code origin #f))) + (if quoted? + (list 'unquote code) + code))) + ((lst ...) + (let ((lst (map (cut object->code <> #t) lst))) + (if quoted? + lst + (list 'quasiquote lst)))) + (obj + obj))) - (define (package-lists->code lsts) - (list 'quasiquote - (map (match-lambda - ((? symbol? s) - (list (symbol->string s) (list 'unquote s))) - ((label pkg . out) - (let ((mod (package-module-name pkg))) - (cons* label - ;; FIXME: using '@ certainly isn't pretty, but it - ;; avoids having to import the individual package - ;; modules. - (list 'unquote - (list '@ mod (variable-name pkg mod))) - out)))) - lsts))) + (define (inputs->code inputs) + (if (redundant-input-labels? inputs) + `(list ,@(map (match-lambda ;no need for input labels ("new style") + ((_ package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (variable-reference module name))) + ((_ package output) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (list 'quasiquote + (list + (list 'unquote + (variable-reference module name)) + output))))) + inputs)) + (list 'quasiquote ;preserve input labels (deprecated) + (object->code inputs #t)))) (let ((name (package-name package)) (version (package-version package)) @@ -154,19 +209,20 @@ when evaluated." '-build-system))) ,@(match arguments (() '()) - (args `((arguments ,(list 'quasiquote args))))) + (_ `((arguments + ,(list 'quasiquote (object->code arguments #t)))))) ,@(match outputs (("out") '()) (outs `((outputs (list ,@outs))))) ,@(match native-inputs (() '()) - (pkgs `((native-inputs ,(package-lists->code pkgs))))) + (pkgs `((native-inputs ,(inputs->code pkgs))))) ,@(match inputs (() '()) - (pkgs `((inputs ,(package-lists->code pkgs))))) + (pkgs `((inputs ,(inputs->code pkgs))))) ,@(match propagated-inputs (() '()) - (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + (pkgs `((propagated-inputs ,(inputs->code pkgs))))) ,@(if (lset= string=? supported-systems %supported-systems) '() `((supported-systems (list ,@supported-systems)))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index b7859c8341..b4284f5c33 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, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -10,6 +10,7 @@ ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -113,7 +114,7 @@ (url distribution-url) ;string (digests distribution-digests) ;list of string pairs (file-name distribution-file-name "filename") ;string - (has-signature? distribution-has-signature? "hash_sig") ;Boolean + (has-signature? distribution-has-signature? "has_sig") ;Boolean (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ... (python-version distribution-package-python-version "python_version")) @@ -128,27 +129,30 @@ missing-source-error? (package missing-source-error-package)) -(define (latest-source-release pypi-package) - "Return the latest source release for PYPI-PACKAGE." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) +(define (latest-version project) + "Return the latest version of PROJECT, a <pypi-project> record." + (project-info-version (pypi-project-info project))) + +(define* (source-release pypi-package + #:optional (version (latest-version pypi-package))) + "Return the source release of VERSION for PYPI-PACKAGE, a <pypi-project> +record, by default the latest version." + (let ((releases (or (assoc-ref (pypi-project-releases pypi-package) version) + '()))) (or (find (lambda (release) (string=? "sdist" (distribution-package-type release))) releases) (raise (condition (&missing-source-error (package pypi-package))))))) -(define (latest-wheel-release pypi-package) +(define* (wheel-release pypi-package + #:optional (version (latest-version pypi-package))) "Return the url of the wheel for the latest release of pypi-package, or #f if there isn't any." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) - (or (find (lambda (release) - (string=? "bdist_wheel" (distribution-package-type release))) - releases) - #f))) + (let ((releases (assoc-ref (pypi-project-releases pypi-package) version))) + (find (lambda (release) + (string=? "bdist_wheel" (distribution-package-type release))) + releases))) (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the @@ -185,7 +189,7 @@ the input field." (() '()) ((package-inputs ...) - `((,input-type (,'quasiquote ,package-inputs)))))) + `((,input-type (list ,@package-inputs)))))) (define %requirement-name-regexp ;; Regexp to match the requirement name in a requirement specification. @@ -404,15 +408,8 @@ return the unaltered list of upstream dependency names." (remove (cut string=? "argparse" <>) deps)) (define (requirement->package-name/sort deps) - (sort - (map (lambda (input) - (let ((guix-name (python->package-name input))) - (list guix-name (list 'unquote (string->symbol guix-name))))) - deps) - (lambda args - (match args - (((a _ ...) (b _ ...)) - (string-ci<? a b)))))) + (map string->symbol + (sort (map python->package-name deps) string-ci<?))) (define process-requirements (compose requirement->package-name/sort strip-argparse)) @@ -426,7 +423,7 @@ return the unaltered list of upstream dependency names." "Return the `package' s-expression for a python package with the given NAME, VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (maybe-upstream-name name) - (if (string-match ".*\\-[0-9]+" (pk name)) + (if (string-match ".*\\-[0-9]+" name) `((properties ,`'(("upstream-name" . ,name)))) '())) @@ -474,7 +471,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." ,@(maybe-inputs native-inputs 'native-inputs) (home-page ,home-page) (synopsis ,synopsis) - (description ,description) + (description ,(beautify-description description)) (license ,(license->symbol license))) upstream-dependencies)))))))) @@ -484,18 +481,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let* ((project (pypi-fetch package-name)) - (info (and project (pypi-project-info project)))) + (info (and=> project pypi-project-info)) + (version (or version (and=> project latest-version)))) (and project (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) (leave (G_ "no source release for pypi package ~a ~a~%") - (project-info-name info) - (project-info-version info))))) - (make-pypi-sexp (project-info-name info) - (project-info-version info) - (and=> (latest-source-release project) + (project-info-name info) version)))) + (make-pypi-sexp (project-info-name info) version + (and=> (source-release project version) distribution-url) - (and=> (latest-wheel-release project) + (and=> (wheel-release project version) distribution-url) (project-info-home-page info) (project-info-summary info) @@ -503,8 +499,9 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (string->license (project-info-license info))))))))) -(define (pypi-recursive-import package-name) +(define* (pypi-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package pypi->guix-package #:guix-name python->package-name)) @@ -537,12 +534,19 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (guard (c ((missing-source-error? c) #f)) (let* ((info (pypi-project-info pypi-package)) (version (project-info-version info)) - (url (distribution-url - (latest-source-release pypi-package)))) + (dist (source-release pypi-package)) + (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))) (package (package-name package)) - (version version) - (urls (list url)))))))) + (version version))))))) (define %pypi-updater (upstream-updater diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 731e69651e..49be982a7f 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,19 +22,18 @@ (define-module (guix import stackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 control) + #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (srfi srfi-43) #:use-module (guix import json) #:use-module (guix import hackage) #:use-module (guix import utils) #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:export (%stackage-url stackage->guix-package stackage-recursive-import @@ -47,15 +47,31 @@ (define %stackage-url (make-parameter "https://www.stackage.org")) -;; Latest LTS version compatible with GHC 8.6.5. -(define %default-lts-version "14.27") +;; Latest LTS version compatible with current GHC. +(define %default-lts-version "18.14") -(define (lts-info-packages lts-info) - "Returns the alist of packages contained in LTS-INFO." - (or (assoc-ref lts-info "packages") '())) +(define-json-mapping <stackage-lts> make-stackage-lts + stackage-lts? + json->stackage-lts + (snapshot stackage-lts-snapshot "snapshot" json->snapshot) + (packages stackage-lts-packages "packages" + (lambda (vector) + (map json->stackage-package (vector->list vector))))) -(define (leave-with-message fmt . args) - (raise (condition (&message (message (apply format #f fmt args)))))) +(define-json-mapping <snapshot> make-snapshot + stackage-snapshot? + json->snapshot + (name snapshot-name) + (ghc-version snapshot-ghc-version) + (compiler snapshot-compiler)) + +(define-json-mapping <stackage-package> make-stackage-package + stackage-package? + json->stackage-package + (origin stackage-package-origin) + (name stackage-package-name) + (version stackage-package-version) + (synopsis stackage-package-synopsis)) (define stackage-lts-info-fetch ;; "Retrieve the information about the LTS Stackage release VERSION." @@ -65,21 +81,15 @@ "/lts-" (if (string-null? version) %default-lts-version version))) - (lts-info (json-fetch url))) - (if lts-info - (reverse lts-info) - (leave-with-message "LTS release version not found: ~a" version)))))) - -(define (stackage-package-name pkg-info) - (assoc-ref pkg-info "name")) - -(define (stackage-package-version pkg-info) - (assoc-ref pkg-info "version")) + (lts-info (and=> (json-fetch url) json->stackage-lts))) + (or lts-info + (raise (formatted-message (G_ "LTS release version not found: ~a") + version))))))) -(define (lts-package-version pkgs-info name) - "Return the version of the package with upstream NAME included in PKGS-INFO." +(define (lts-package-version packages name) + "Return the version of the package with upstream NAME included in PACKAGES." (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) - (vector->list pkgs-info)))) + packages))) (stackage-package-version pkg))) @@ -96,21 +106,22 @@ #:key (include-test-dependencies? #t) (lts-version %default-lts-version) - (packages-info - (lts-info-packages + (packages + (stackage-lts-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." - (let* ((version (lts-package-version packages-info package-name)) + (let* ((version (lts-package-version packages package-name)) (name-version (hackage-name-version package-name version))) (if name-version (hackage->guix-package name-version #:include-test-dependencies? include-test-dependencies?) - (leave-with-message "~a: Stackage package not found" package-name)))))) + (raise (formatted-message (G_ "~a: Stackage package not found") + package-name))))))) (define (stackage-recursive-import package-name . args) (recursive-import package-name @@ -124,43 +135,46 @@ included in the Stackage LTS release." ;;; (define latest-lts-release - (let ((pkgs-info - (mlambda () (lts-info-packages - (stackage-lts-info-fetch %default-lts-version))))) - (lambda* (package) + (let ((packages + (mlambda () + (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))))) + (lambda* (pkg) "Return an <upstream-source> for the latest Stackage LTS release of PACKAGE or #f if the package is not included in the Stackage LTS release." - (let* ((hackage-name (guix-package->hackage-name package)) - (version (lts-package-version (pkgs-info) hackage-name)) + (let* ((hackage-name (guix-package->hackage-name pkg)) + (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) (match (and=> name-version hackage-fetch) - (#f (format (current-error-port) - "warning: failed to parse ~a~%" - (hackage-cabal-url hackage-name)) - #f) + (#f + (warning (G_ "failed to parse ~a~%") + (hackage-cabal-url hackage-name)) + #f) (_ (let ((url (hackage-source-url hackage-name version))) (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (list url)))))))))) + (urls (list url)) + (input-changes + (changed-inputs + pkg + (stackage->guix-package hackage-name #:packages (packages)))))))))))) -(define (stackage-package? package) - "Whether PACKAGE is available on the default Stackage LTS release." +(define (stackage-lts-package? package) + "Return whether PACKAGE is available on the default Stackage LTS release." (and (hackage-package? package) - (let ((packages (lts-info-packages + (let ((packages (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))) (hackage-name (guix-package->hackage-name package))) - (vector-any identity - (vector-map - (lambda (_ metadata) - (string=? (cdr (list-ref metadata 2)) hackage-name)) - packages))))) + (find (lambda (package) + (string=? (stackage-package-name package) hackage-name)) + packages)))) (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") - (pred stackage-package?) + (pred stackage-lts-package?) (latest latest-lts-release))) ;;; stackage.scm ends here diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 18d8b95ee0..c741555928 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -18,19 +18,18 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import texlive) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (sxml xpath) - #:use-module (srfi srfi-11) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (web uri) - #:use-module (guix diagnostics) - #:use-module (guix i18n) - #:use-module (guix http-client) #:use-module (gcrypt hash) + #:use-module (guix derivations) #:use-module (guix memoization) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix serialization) @@ -39,24 +38,16 @@ #:use-module (guix utils) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (guix build-system texlive) - #:export (texlive->guix-package - - fetch-sxml - sxml->package)) + #:export (files-differ? + texlive->guix-package + texlive-recursive-import)) ;;; Commentary: ;;; -;;; Generate a package declaration template for the latest version of a -;;; package on CTAN, using the XML output produced by the XML API to the CTAN -;;; database at http://www.ctan.org/xml/1.2/ -;;; -;;; Instead of taking the packages from CTAN, however, we fetch the sources -;;; from the SVN repository of the Texlive project. We do this because CTAN -;;; only keeps a single version of each package whereas we can access any -;;; version via SVN. Unfortunately, this means that the importer is really -;;; just a Texlive importer, not a generic CTAN importer. +;;; Generate a package declaration template for corresponding package in the +;;; Tex Live Package Database (tlpdb). We fetch all sources from different +;;; locations in the SVN repository of the Texlive project. ;;; ;;; Code: @@ -79,6 +70,8 @@ ("bsd4" 'bsd-4) ("opl" 'opl1.0+) ("ofl" 'silofl1.1) + + ("lpplgpl" `(list lppl gpl1+)) ("lppl" 'lppl) ("lppl1" 'lppl1.0+) ; usually means "or later" ("lppl1.2" 'lppl1.2+) ; usually means "or later" @@ -107,91 +100,211 @@ ("cc-by-nc-nd-4" 'non-free) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) - (_ #f))) - -(define (fetch-sxml name) - "Return an sxml representation of the package information contained in the -XML description of the CTAN package or #f in case of failure." - ;; This API always returns the latest release of the module. - (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (xml->sxml (http-fetch url) - #:trim-whitespace? #t)))) + (x `(error unknown-license ,x)))) -(define (guix-name component name) +(define (guix-name name) "Return a Guix package name for a given Texlive package NAME." - (string-append "texlive-" component "-" + (string-append "texlive-" (string-map (match-lambda (#\_ #\-) (#\. #\-) (chr (char-downcase chr))) name))) -(define* (sxml->package sxml #:optional (component "latex")) - "Return the `package' s-expression for a Texlive package from the SXML -expression describing it." - (define (sxml-value path) - (match ((sxpath path) sxml) - (() #f) - ((val) val))) +(define (tlpdb-file) + (define texlive-bin + ;; Resolve this variable lazily so that (gnu packages ...) does not end up + ;; in the closure of this module. + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-bin)) + (with-store store - (let* ((id (sxml-value '(entry @ id *text*))) - (synopsis (sxml-value '(entry caption *text*))) - (version (or (sxml-value '(entry version @ number *text*)) - (sxml-value '(entry version @ date *text*)))) - (license (match ((sxpath '(entry license @ type *text*)) sxml) - ((license) (string->license license)) - ((lst ...) (map string->license lst)))) - (home-page (string-append "http://www.ctan.org/pkg/" id)) - (ref (texlive-ref component id)) - (checkout (download-svn-to-store store ref))) - (unless checkout - (warning (G_ "Could not determine source location. \ -Please manually specify the source field.~%"))) - `(package - (name ,(guix-name component id)) - (version ,version) - (source ,(if checkout - `(origin - (method svn-fetch) - (uri (texlive-ref ,component ,id)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file checkout port) - (force-output port) - (get-hash)))))) - #f)) - (build-system texlive-build-system) - (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,(string-trim-both - (string-join - (map string-trim-both - (string-split - (beautify-description - (sxml->string (or (sxml-value '(entry description)) - '()))) - #\newline))))) - (license ,(match license - ((lst ...) `(list ,@lst)) - (license license))))))) + (run-with-store store + (mlet* %store-monad + ((drv (lower-object texlive-bin)) + (built (built-derivations (list drv)))) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (string-append (first items) + "/share/tlpkg/texlive.tlpdb")))))))) + +(define tlpdb + (memoize + (lambda () + (let ((file (tlpdb-file)) + (fields + '((name . string) + (shortdesc . string) + (longdesc . string) + (catalogue-license . string) + (catalogue-ctan . string) + (srcfiles . list) + (runfiles . list) + (docfiles . list) + (depend . simple-list))) + (record + (lambda* (key value alist #:optional (type 'string)) + (let ((new + (or (and=> (assoc-ref alist key) + (lambda (existing) + (cond + ((eq? type 'string) + (string-append existing " " value)) + ((or (eq? type 'list) (eq? type 'simple-list)) + (cons value existing))))) + (cond + ((eq? type 'string) + value) + ((or (eq? type 'list) (eq? type 'simple-list)) + (list value)))))) + (acons key new (alist-delete key alist)))))) + (call-with-input-file file + (lambda (port) + (let loop ((all (list)) + (current (list)) + (last-property #false)) + (let ((line (read-line port))) + (cond + ((eof-object? line) all) + + ;; End of record. + ((string-null? line) + (loop (cons (cons (assoc-ref current 'name) current) + all) + (list) #false)) + + ;; Continuation of a list + ((and (zero? (string-index line #\space)) last-property) + ;; Erase optional second part of list values like + ;; "details=Readme" for files + (let ((plain-value (first + (string-split + (string-trim-both line) #\space)))) + (loop all (record last-property + plain-value + current + 'list) + last-property))) + (else + (or (and-let* ((space (string-index line #\space)) + (key (string->symbol (string-take line space))) + (value (string-drop line (1+ space))) + (field-type (assoc-ref fields key))) + ;; Erase second part of list keys like "size=29" + (cond + ((eq? field-type 'list) + (loop all current key)) + (else + (loop all (record key value current field-type) key)))) + (loop all current #false)))))))))))) + +(define* (files-differ? directory package-name + #:key + (package-database tlpdb) + (type #false) + (direction 'missing)) + "Return a list of files in DIRECTORY that differ from the expected installed +files for PACKAGE-NAME according to the PACKAGE-DATABASE. By default all +files considered, but this can be restricted by setting TYPE to 'runfiles, +'docfiles, or 'srcfiles. The names of files that are missing from DIRECTORY +are returned; by setting DIRECTION to anything other than 'missing, the names +of those files are returned that are unexpectedly installed." + (define (strip-directory-prefix file-name) + (string-drop file-name (1+ (string-length directory)))) + (let* ((data (or (assoc-ref (package-database) package-name) + (error (format #false + "~a is not a valid package name in the TeX Live package database." + package-name)))) + (files (if type + (or (assoc-ref data type) (list)) + (append (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'srcfiles) (list))))) + (existing (file-system-fold + (const #true) ;enter? + (lambda (path stat result) (cons path result)) ;leaf + (lambda (path stat result) result) ;down + (lambda (path stat result) result) ;up + (lambda (path stat result) result) ;skip + (lambda (path stat errno result) result) ;error + (list) + directory))) + (if (eq? direction 'missing) + (lset-difference string=? + files (map strip-directory-prefix existing)) + ;; List files that are installed but should not be. + (lset-difference string=? + (map strip-directory-prefix existing) files)))) + +(define (files->directories files) + (define name->parts (cut string-split <> #\/)) + (map (cut string-join <> "/" 'suffix) + (delete-duplicates (map (lambda (file) + (drop-right (name->parts file) 1)) + (sort files string<)) + ;; Remove sub-directories, i.e. more specific + ;; entries with the same prefix. + (lambda (x y) (every equal? x y))))) + +(define (tlpdb->package name package-database) + (and-let* ((data (assoc-ref package-database name)) + (dirs (files->directories + (map (lambda (dir) + (string-drop dir (string-length "texmf-dist/"))) + (append (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'srcfiles) (list)))))) + (name (guix-name name)) + (version (number->string %texlive-revision)) + (ref (svn-multi-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist")) + (locations dirs) + (revision %texlive-revision))) + (source (with-store store + (download-multi-svn-to-store + store ref (string-append name "-svn-multi-checkout"))))) + (values + `(package + (inherit (simple-texlive-package + ,name + (list ,@dirs) + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file source port) + (force-output port) + (get-hash)))) + ,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true)))) + ,@(or (and=> (assoc-ref data 'depend) + (lambda (inputs) + `((propagated-inputs + (list ,@(map (lambda (tex-name) + (let ((name (guix-name tex-name))) + (string->symbol name))) + inputs)))))) + '()) + ,@(or (and=> (assoc-ref data 'catalogue-ctan) + (lambda (url) + `((home-page ,(string-append "https://ctan.org" url))))) + '((home-page "https://www.tug.org/texlive/"))) + (synopsis ,(assoc-ref data 'shortdesc)) + (description ,(beautify-description + (assoc-ref data 'longdesc))) + (license ,(string->license + (assoc-ref data 'catalogue-license)))) + (or (assoc-ref data 'depend) (list))))) (define texlive->guix-package (memoize - (lambda* (package-name #:optional (component "latex")) - "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' + (lambda* (name #:key repo version (package-database tlpdb)) + "Find the metadata for NAME in the tlpdb and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-sxml package-name) - (cut sxml->package <> component))))) + (tlpdb->package name (package-database))))) + +(define (texlive-recursive-import name) + (recursive-import name + #:repo->guix-package texlive->guix-package + #:guix-name guix-name)) -;;; ctan.scm ends here +;;; texlive.scm ends here diff --git a/guix/import/utils.scm b/guix/import/utils.scm index a180742ca3..1c3cfa3e0b 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,7 @@ #:use-module (guix store) #:use-module (guix download) #:use-module (guix sets) + #:use-module (guix ui) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -152,6 +154,7 @@ of the string VERSION is replaced by the symbol 'version." ("CC0-1.0" 'license:cc0) ("CC-BY-2.0" 'license:cc-by2.0) ("CC-BY-3.0" 'license:cc-by3.0) + ("CC-BY-4.0" 'license:cc-by4.0) ("CC-BY-SA-2.0" 'license:cc-by-sa2.0) ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) @@ -163,6 +166,7 @@ of the string VERSION is replaced by the symbol 'version." ("EPL-1.0" 'license:epl1.0) ("MIT" 'license:expat) ("FTL" 'license:freetype) + ("Freetype" 'license:freetype) ("GFDL-1.1" 'license:fdl1.1+) ("GFDL-1.2" 'license:fdl1.2+) ("GFDL-1.3" 'license:fdl1.3+) @@ -179,6 +183,7 @@ of the string VERSION is replaced by the symbol 'version." ("GPL-3.0-only" 'license:gpl3) ("GPL-3.0+" 'license:gpl3+) ("GPL-3.0-or-later" 'license:gpl3+) + ("HPND" 'license:hpnd) ("ISC" 'license:isc) ("IJG" 'license:ijg) ("Imlib2" 'license:imlib2) @@ -231,9 +236,10 @@ to in the (guix licenses) module, or #f if there is no such known license." with dashes." (string-join (string-split (string-downcase str) #\_) "-")) -(define (beautify-description description) - "Improve the package DESCRIPTION by turning a beginning sentence fragment -into a proper sentence and by using two spaces between sentences." +(define* (beautify-description description #:optional (length 80)) + "Improve the package DESCRIPTION by turning a beginning sentence fragment into +a proper sentence and by using two spaces between sentences, and wrap lines at +LENGTH characters." (let ((cleaned (cond ((string-prefix? "A " description) (string-append "This package provides a" @@ -248,8 +254,9 @@ into a proper sentence and by using two spaces between sentences." (string-length "Functions")))) (else description)))) ;; Use double spacing between sentences - (regexp-substitute/global #f "\\. \\b" - cleaned 'pre ". " 'post))) + (fill-paragraph (regexp-substitute/global #f "\\. \\b" + cleaned 'pre ". " 'post) + length))) (define* (package-names->package-inputs names #:optional (output #f)) "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an |