summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/cabal.scm40
-rw-r--r--guix/import/cran.scm4
-rw-r--r--guix/import/egg.scm357
-rw-r--r--guix/import/elpa.scm4
-rw-r--r--guix/import/git.scm225
-rw-r--r--guix/import/go.scm392
-rw-r--r--guix/import/hackage.scm27
-rw-r--r--guix/import/launchpad.scm30
-rw-r--r--guix/import/minetest.scm468
-rw-r--r--guix/import/opam.scm160
-rw-r--r--guix/import/print.scm6
-rw-r--r--guix/import/pypi.scm24
-rw-r--r--guix/import/snix.scm467
-rw-r--r--guix/import/stackage.scm17
-rw-r--r--guix/import/utils.scm44
15 files changed, 1498 insertions, 767 deletions
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index da00019297..98d7234098 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -145,7 +146,7 @@ to the stack."
(lalr-parser
;; --- token definitions
(CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE
- (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
+ (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY)
(left: OR)
(left: PROPERTY AND)
(right: ELSE NOT))
@@ -155,6 +156,7 @@ to the stack."
(sections source-repo) : (append $1 (list $2))
(sections executables) : (append $1 $2)
(sections test-suites) : (append $1 $2)
+ (sections common) : (append $1 $2)
(sections custom-setup) : (append $1 $2)
(sections benchmarks) : (append $1 $2)
(sections lib-sec) : (append $1 (list $2))
@@ -178,6 +180,10 @@ to the stack."
(ts-sec) : (list $1))
(ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
(TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3))
+ (common (common common-sec) : (append $1 (list $2))
+ (common-sec) : (list $1))
+ (common-sec (COMMON OCURLY exprs CCURLY) : `(section common ,$1 ,$3)
+ (COMMON open exprs close) : `(section common ,$1 ,$3))
(custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2)))
(benchmarks (benchmarks bm-sec) : (append $1 (list $2))
(bm-sec) : (list $1))
@@ -367,6 +373,9 @@ matching a string against the created regexp."
(define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)"
regexp/icase))
+(define is-common (make-rx-matcher "^common +([a-z0-9_-]+)"
+ regexp/icase))
+
(define is-custom-setup (make-rx-matcher "^(custom-setup)"
regexp/icase))
@@ -391,14 +400,20 @@ matching a string against the created regexp."
(define (is-or s) (string=? s "||"))
-(define (is-id s port)
+(define (is-id s port loc)
(let ((cabal-reserved-words
'("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
- "source-repository" "benchmark"))
+ "source-repository" "benchmark" "common"))
(spaces (read-while (cut char-set-contains? char-set:blank <>) port))
(c (peek-char port)))
(unread-string spaces port)
- (and (every (cut string-ci<> s <>) cabal-reserved-words)
+ ;; Sometimes the name of an identifier is the same as one of the reserved
+ ;; words, which would normally lead to an error, see
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25138>. Unless the word
+ ;; is at the beginning of a line (excluding whitespace), treat is as just
+ ;; another identifier instead of a reserved word.
+ (and (or (not (= (source-location-column loc) (current-indentation)))
+ (every (cut string-ci<> s <>) cabal-reserved-words))
(and (not (char=? (last (string->list s)) #\:))
(not (char=? #\: c))))))
@@ -469,6 +484,8 @@ string with the read characters."
(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))
+(define (lex-common common-rx-res loc) (lex-rx-res common-rx-res 'COMMON loc))
+
(define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc))
(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))
@@ -558,7 +575,7 @@ LOC is the current port location."
((is-none w) (lex-none loc))
((is-and w) (lex-and loc))
((is-or w) (lex-or loc))
- ((is-id w port) (lex-id w loc))
+ ((is-id w port loc) (lex-id w loc))
(else (unread-string w port) #f))))
(define (lex-line port loc)
@@ -570,6 +587,7 @@ the current port location."
((is-src-repo s) => (cut lex-src-repo <> loc))
((is-exec s) => (cut lex-exec <> loc))
((is-test-suite s) => (cut lex-test-suite <> loc))
+ ((is-common s) => (cut lex-common <> loc))
((is-custom-setup s) => (cut lex-custom-setup <> loc))
((is-benchmark s) => (cut lex-benchmark <> loc))
((is-lib s) (lex-lib loc))
@@ -796,7 +814,16 @@ the ordering operation and the version."
(let ((value (or (assoc-ref env name)
(assoc-ref (cabal-flags->alist (cabal-flags)) name))))
(if (eq? value 'false) #f #t)))
+
+ (define common-stanzas
+ (filter-map (match-lambda
+ (('section 'common common-name common)
+ (cons common-name common))
+ (_ #f))
+ cabal-sexp))
+
(define (eval sexp)
+ "Given an SEXP and an ENV, return the evaluated (SEXP . ENV)."
(match sexp
(() '())
;; nested 'if'
@@ -831,6 +858,9 @@ the ordering operation and the version."
(list 'section type name (eval parameters)))
(((? string? name) values)
(list name values))
+ ((("import" imports) rest ...)
+ (eval (append (append-map (cut assoc-ref common-stanzas <>) imports)
+ rest)))
((element rest ...)
(cons (eval element) (eval rest)))
(_ (raise (condition
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index dbc858cb84..f649928c5a 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -153,9 +153,9 @@ package definition."
(define %cran-canonical-url "https://cran.r-project.org/package=")
(define %bioconductor-url "https://bioconductor.org/packages/")
-;; The latest Bioconductor release is 3.12. Bioconductor packages should be
+;; The latest Bioconductor release is 3.13. Bioconductor packages should be
;; updated together.
-(define %bioconductor-version "3.12")
+(define %bioconductor-version "3.13")
(define* (bioconductor-packages-list-url #:optional type)
(string-append "https://bioconductor.org/packages/"
diff --git a/guix/import/egg.scm b/guix/import/egg.scm
new file mode 100644
index 0000000000..89e7a9160d
--- /dev/null
+++ b/guix/import/egg.scm
@@ -0,0 +1,357 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import egg)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-71)
+ #:use-module (gcrypt hash)
+ #:use-module (guix git)
+ #:use-module (guix i18n)
+ #:use-module (guix base32)
+ #:use-module (guix diagnostics)
+ #:use-module (guix memoization)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system chicken)
+ #:use-module (guix store)
+ #:use-module ((guix download) #:select (download-to-store url-fetch))
+ #:use-module (guix import utils)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:export (egg->guix-package
+ egg-recursive-import
+ %egg-updater
+
+ ;; For tests.
+ guix-package->egg-name))
+
+;;; Commentary:
+;;;
+;;; (guix import egg) provides package importer for CHICKEN eggs. See the
+;;; official specification format for eggs
+;;; <https://wiki.call-cc.org/man/5/Egg%20specification%20format>.
+;;;
+;;; 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.
+;;;
+;;; * All the eggs are stored as tarballs at
+;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for
+;;; the egg from there.
+;;;
+;;; * The rest of the package fields will be parsed from the PACKAGE.egg file.
+;;;
+;;; Todos:
+;;;
+;;; * Support for CHICKEN 4?
+;;;
+;;; * Some packages will specify a specific version of a depencency in the
+;;; PACKAGE.egg file, how should we handle this?
+;;;
+;;; Code:
+
+
+;;;
+;;; Egg metadata fetcher and helper functions.
+;;;
+
+(define package-name-prefix "chicken-")
+
+(define %eggs-url
+ (make-parameter "https://code.call-cc.org/egg-tarballs/5"))
+
+(define %eggs-home-page
+ (make-parameter "https://wiki.call-cc.org/egg"))
+
+(define (egg-source-url name version)
+ "Return the URL to the source tarball for version VERSION of the CHICKEN egg
+NAME."
+ `(egg-uri ,name version))
+
+(define (egg-name->guix-name name)
+ "Return the package name for CHICKEN egg NAME."
+ (string-append package-name-prefix 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")
+ (directory commit _ (update-cached-checkout url)))
+ directory))
+
+(define (egg-directory name)
+ "Return the directory containing the source code for the egg NAME."
+ (let ((eggs-directory (eggs-repository)))
+ (string-append eggs-directory "/" name)))
+
+(define (find-latest-version name)
+ "Get the latest version of the egg NAME."
+ (let ((directory (scandir (egg-directory name))))
+ (if directory
+ (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."
+ (call-with-input-file (or file
+ (string-append (egg-directory name) "/"
+ (find-latest-version name)
+ "/" name ".egg"))
+ read))
+
+(define (guix-name->egg-name name)
+ "Return the CHICKEN egg name corresponding to the Guix package NAME."
+ (if (string-prefix? package-name-prefix name)
+ (string-drop name (string-length package-name-prefix))
+ name))
+
+(define (guix-package->egg-name package)
+ "Return the CHICKEN egg name of the Guix CHICKEN PACKAGE."
+ (or (assq-ref (package-properties package) 'upstream-name)
+ (guix-name->egg-name (package-name package))))
+
+(define (egg-package? package)
+ "Check if PACKAGE is an CHICKEN egg package."
+ (and (eq? (package-build-system package) chicken-build-system)
+ (string-prefix? package-name-prefix (package-name package))))
+
+(define string->license
+ ;; Doesn't seem to use a specific format.
+ ;; <https://wiki.call-cc.org/eggs-licensing>
+ (match-lambda
+ ("GPL-2" 'license:gpl2)
+ ("GPL-2+" 'license:gpl2+)
+ ("GPL-3" 'license:gpl3)
+ ("GPL-3+" 'license:gpl3+)
+ ("GPL" 'license:gpl?)
+ ("AGPL-3" 'license:agpl3)
+ ("AGPL" 'license:agpl?)
+ ("LGPL-2.0" 'license:lgpl2.0)
+ ("LGPL-2.0+" 'license:lgpl2.0+)
+ ("LGPL-2.1" 'license:lgpl2.1)
+ ("LGPL-2.1+" 'license:lgpl2.1+)
+ ("LGPL-3" 'license:lgpl3)
+ ("LGPL-3" 'license:lgpl3+)
+ ("LGPL" 'license:lgpl?)
+ ("BSD-1-Clause" 'license:bsd-1)
+ ("BSD-2-Clause" 'license:bsd-2)
+ ("BSD-3-Clause" 'license:bsd-3)
+ ("BSD" 'license:bsd?)
+ ("MIT" 'license:expat)
+ ("ISC" 'license:isc)
+ ("Artistic-2" 'license:artistic2.0)
+ ("Apache-2.0" 'license:asl2.0)
+ ("Public Domain" 'license:public-domain)
+ ((x) (string->license x))
+ ((lst ...) `(list ,@(map string->license lst)))
+ (_ #f)))
+
+
+;;;
+;;; 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.
+
+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
+downloaded.
+
+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)))
+ (if (not egg-content)
+ (values #f '()) ; egg doesn't exist
+ (let* ((version* (or (assoc-ref egg-content 'version)
+ (find-latest-version name)))
+ (version (if (list? version*) (first version*) version*))
+ (source-url (if source #f (egg-source-url name version)))
+ (tarball (if source
+ #f
+ (with-store store
+ (download-to-store
+ store (egg-uri name version))))))
+
+ (define egg-home-page
+ (string-append (%eggs-home-page) "/" name))
+
+ (define egg-synopsis
+ (match (assoc-ref egg-content 'synopsis)
+ ((synopsis) synopsis)
+ (_ #f)))
+
+ (define egg-licenses
+ (let ((licenses*
+ (match (assoc-ref egg-content 'license)
+ ((license)
+ (map string->license (string-split license #\/)))
+ (#f
+ '()))))
+ (match licenses*
+ ((license) license)
+ ((license1 license2 ...) `(list ,@licenses*)))))
+
+ (define (maybe-symbol->string sym)
+ (if (symbol? sym) (symbol->string sym) sym))
+
+ (define (prettify-system-dependency name)
+ ;; System dependencies sometimes have spaces and/or upper case
+ ;; letters in them.
+ ;;
+ ;; There will probably still be some weird edge cases.
+ (string-map (lambda (char)
+ (case char
+ ((#\space) #\-)
+ (else char)))
+ (maybe-symbol->string name)))
+
+ (define* (egg-parse-dependency name #:key (system? #f))
+ (define extract-name
+ (match-lambda
+ ((name version) name)
+ (name name)))
+
+ (define (prettify-name name)
+ (if system?
+ (prettify-system-dependency name)
+ (maybe-symbol->string name)))
+
+ (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))))))
+
+ (define egg-propagated-inputs
+ (let ((dependencies (assoc-ref egg-content 'dependencies)))
+ (if (list? dependencies)
+ (map egg-parse-dependency
+ dependencies)
+ '())))
+
+ ;; TODO: Or should these be propagated?
+ (define egg-inputs
+ (let ((dependencies (assoc-ref egg-content 'foreign-dependencies)))
+ (if (list? dependencies)
+ (map (lambda (name)
+ (egg-parse-dependency name #:system? #t))
+ dependencies)
+ '())))
+
+ (define egg-native-inputs
+ (let* ((test-dependencies (or (assoc-ref egg-content
+ 'test-dependencies)
+ '()))
+ (build-dependencies (or (assoc-ref egg-content
+ 'build-dependencies)
+ '()))
+ (test+build-dependencies (append test-dependencies
+ build-dependencies)))
+ (match test+build-dependencies
+ ((_ _ ...) (map egg-parse-dependency
+ test+build-dependencies))
+ (() '()))))
+
+ ;; Copied from (guix import hackage).
+ (define (maybe-inputs input-type inputs)
+ (match inputs
+ (()
+ '())
+ ((inputs ...)
+ (list (list input-type
+ (list 'quasiquote inputs))))))
+
+ (values
+ `(package
+ (name ,(egg-name->guix-name name))
+ (version ,version)
+ (source
+ ,(if source
+ source
+ `(origin
+ (method url-fetch)
+ (uri ,source-url)
+ (sha256
+ (base32 ,(if tarball
+ (bytevector->nix-base32-string
+ (file-sha256 tarball))
+ "failed to download tar archive"))))))
+ (build-system chicken-build-system)
+ (arguments ,(list 'quasiquote (list #:egg-name name)))
+ ,@(maybe-inputs 'native-inputs egg-native-inputs)
+ ,@(maybe-inputs 'inputs egg-inputs)
+ ,@(maybe-inputs 'propagated-inputs egg-propagated-inputs)
+ (home-page ,egg-home-page)
+ (synopsis ,egg-synopsis)
+ (description #f)
+ (license ,egg-licenses))
+ (filter (lambda (name)
+ (not (member name '("srfi-4"))))
+ (map (compose guix-name->egg-name first)
+ (append egg-propagated-inputs
+ egg-native-inputs)))))))
+
+(define egg->guix-package/m ;memoized variant
+ (memoize egg->guix-package))
+
+(define (egg-recursive-import package-name)
+ (recursive-import package-name
+ #:repo->guix-package (lambda* (name #:key version repo)
+ (egg->guix-package/m name))
+ #:guix-name egg-name->guix-name))
+
+
+;;;
+;;; Updater.
+;;;
+
+(define (latest-release package)
+ "Return an @code{<upstream-source>} for the latest release of PACKAGE."
+ (let* ((egg-name (guix-package->egg-name package))
+ (version (find-latest-version egg-name))
+ (source-url (egg-source-url egg-name version)))
+ (upstream-source
+ (package (package-name package))
+ (version version)
+ (urls (list source-url)))))
+
+(define %egg-updater
+ (upstream-updater
+ (name 'egg)
+ (description "Updater for CHICKEN egg packages")
+ (pred egg-package?)
+ (latest latest-release)))
+
+;;; egg.scm ends here
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index c0dc5acf51..96ebc17af1 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -80,6 +81,7 @@ NAMES (strings)."
(let ((elpa-archives
'((gnu . "https://elpa.gnu.org/packages")
(gnu/http . "http://elpa.gnu.org/packages") ;for testing
+ (nongnu . "https://elpa.nongnu.org/nongnu")
(melpa-stable . "https://stable.melpa.org/packages")
(melpa . "https://melpa.org/packages"))))
(assq-ref elpa-archives repo)))
@@ -257,7 +259,7 @@ RECIPE."
((assoc-ref recipe #:commit)
=> (lambda (commit) (cons 'commit commit)))
(else
- '(branch . "master"))))
+ '())))
(let-values (((directory commit) (download-git-repository url ref)))
`(origin
diff --git a/guix/import/git.scm b/guix/import/git.scm
new file mode 100644
index 0000000000..1eb219f3fe
--- /dev/null
+++ b/guix/import/git.scm
@@ -0,0 +1,225 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import git)
+ #:use-module (guix build utils)
+ #:use-module (guix diagnostics)
+ #:use-module (guix git)
+ #:use-module (guix git-download)
+ #:use-module (guix i18n)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (%generic-git-updater
+
+ ;; For tests.
+ latest-git-tag-version))
+
+;;; Commentary:
+;;;
+;;; This module provides a generic package updater for packages hosted on Git
+;;; repositories.
+;;;
+;;; It tries to be smart about tag names, but if it is not automatically able
+;;; to parse the tag names correctly, users can set the `release-tag-prefix',
+;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the
+;;; package to make the updater parse the Git tag name correctly.
+;;;
+;;; Possible improvements:
+;;;
+;;; * More robust method for trying to guess the delimiter. Maybe look at the
+;;; previous version/tag combo to determine the delimiter.
+;;;
+;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g.,
+;;; 2021.12.31. Honor a `release-tag-date-scheme?' property?
+;;;
+;;; Code:
+
+;;; Errors & warnings
+
+(define-condition-type &git-no-valid-tags-error &error
+ git-no-valid-tags-error?)
+
+(define (git-no-valid-tags-error)
+ (raise (condition (&message (message "no valid tags found"))
+ (&git-no-valid-tags-error))))
+
+(define-condition-type &git-no-tags-error &error
+ git-no-tags-error?)
+
+(define (git-no-tags-error)
+ (raise (condition (&message (message "no tags were found"))
+ (&git-no-tags-error))))
+
+
+;;; Updater
+
+(define %pre-release-words
+ '("alpha" "beta" "rc" "dev" "test" "pre"))
+
+(define %pre-release-rx
+ (map (lambda (word)
+ (make-regexp (string-append ".+" word) regexp/icase))
+ %pre-release-words))
+
+(define* (version-mapping tags #:key prefix suffix delim pre-releases?)
+ "Given a list of Git TAGS, return an association list where the car is the
+version corresponding to the tag, and the cdr is the name of the tag."
+ (define (guess-delimiter)
+ (let ((total (length tags))
+ (dots (reduce + 0 (map (cut string-count <> #\.) tags)))
+ (dashes (reduce + 0 (map (cut string-count <> #\-) tags)))
+ (underscores (reduce + 0 (map (cut string-count <> #\_) tags))))
+ (cond
+ ((>= dots (* total 0.35)) ".")
+ ((>= dashes (* total 0.8)) "-")
+ ((>= underscores (* total 0.8)) "_")
+ (else ""))))
+
+ (define delim-rx (regexp-quote (or delim (guess-delimiter))))
+ (define suffix-rx (string-append (or suffix "") "$"))
+ (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*")))
+ (define pre-release-rx
+ (if pre-releases?
+ (string-append "(.*(" (string-join %pre-release-words "|") ").*)")
+ ""))
+
+ (define tag-rx
+ (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*"
+ "(" delim-rx "[^[:punct:]" delim-rx "]+)"
+ ;; If there are no delimiters, it could mean that the
+ ;; version just contains one number (e.g., "2"), thus, use
+ ;; "*" instead of "+" to match zero or more numbers.
+ (if (string=? delim-rx "") "*" "+") ")"
+ ;; We don't want the pre-release stuff (e.g., "-alpha") be
+ ;; part of the first group; otherwise, the "-" in "-alpha"
+ ;; might be interpreted as a delimiter, and thus replaced
+ ;; with "."
+ pre-release-rx suffix-rx))
+
+
+
+ (define (get-version tag)
+ (let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
+ (and=> (and tag-match
+ (regexp-substitute/global
+ #f delim-rx (match:substring tag-match 1)
+ ;; If there were no delimiters, don't insert ".".
+ 'pre (if (string=? delim-rx "") "" ".") 'post))
+ (lambda (version)
+ (if pre-releases?
+ (string-append version (match:substring tag-match 3))
+ version)))))
+
+ (define (entry<? a b)
+ (eq? (version-compare (car a) (car b)) '<))
+
+ (stable-sort (filter-map (lambda (tag)
+ (let ((version (get-version tag)))
+ (and version (cons version tag))))
+ tags)
+ entry<?))
+
+(define* (latest-tag url #:key prefix suffix delim pre-releases?)
+ "Return the latest version and corresponding tag available from the Git
+repository at URL."
+ (define (pre-release? tag)
+ (any (cut regexp-exec <> tag)
+ %pre-release-rx))
+
+ (let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
+ (remote-refs url #:tags? #t)))
+ (versions->tags
+ (version-mapping (if pre-releases?
+ tags
+ (filter (negate pre-release?) tags))
+ #:prefix prefix
+ #:suffix suffix
+ #:delim delim
+ #:pre-releases? pre-releases?)))
+ (cond
+ ((null? tags)
+ (git-no-tags-error))
+ ((null? versions->tags)
+ (git-no-valid-tags-error))
+ (else
+ (match (last versions->tags)
+ ((version . tag)
+ (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."
+ (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)
+ ((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))
+ (let* ((source (package-source package))
+ (url (git-reference-url (origin-uri source)))
+ (property (cute assq-ref (package-properties package) <>)))
+ (latest-tag url
+ #:prefix (property 'release-tag-prefix)
+ #:suffix (property 'release-tag-suffix)
+ #:delim (property 'release-tag-version-delimiter)
+ #:pre-releases? (property 'accept-pre-releases?)))))
+
+(define (git-package? package)
+ "Return true if PACKAGE is hosted on a Git repository."
+ (match (package-source package)
+ ((? origin? origin)
+ (and (eq? (origin-method origin) git-fetch)
+ (git-reference? (origin-uri origin))))
+ (_ #f)))
+
+(define (latest-git-release package)
+ "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
+ (upstream-source
+ (package name)
+ (version new-version)
+ (urls (list url))))))
+
+(define %generic-git-updater
+ (upstream-updater
+ (name 'generic-git)
+ (description "Updater for packages hosted on Git repositories")
+ (pred git-package?)
+ (latest latest-git-release)))
diff --git a/guix/import/go.scm b/guix/import/go.scm
index bc53f8f558..9769b557ae 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -5,6 +5,8 @@
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,13 +35,14 @@
#:use-module (guix http-client)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix memoization)
- #:use-module (htmlprag) ;from Guile-Lib
+ #: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)
#:use-module (ice-9 match)
+ #:use-module (ice-9 peg)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
@@ -61,11 +64,9 @@
#:use-module (web uri)
#:export (go-module->guix-package
+ go-module->guix-package*
go-module-recursive-import))
-;;; Parameterize htmlprag to parse valid HTML more reliably.
-(%strict-tokenizer? #t)
-
;;; Commentary:
;;;
;;; (guix import go) attempts to make it easier to create Guix package
@@ -148,26 +149,26 @@ name (e.g. \"github.com/golang/protobuf/proto\")."
;; Extract the text contained in a h2 child node of any
;; element marked with a "License" class attribute.
(select (sxpath `(// (* (@ (equal? (class "License"))))
- h2 // *text*))))
- (select (html->sxml body))))
+ h2 // div // *text*))))
+ (select (html->sxml body #:strict? #t))))
(define (sxml->texi sxml-node)
"A very basic SXML to Texinfo converter which attempts to preserve HTML
formatting and links as text."
(sxml-match sxml-node
- ((strong ,text)
- (format #f "@strong{~a}" text))
- ((a (@ (href ,url)) ,text)
- (format #f "@url{~a,~a}" url text))
- ((code ,text)
- (format #f "@code{~a}" text))
- (,something-else something-else)))
+ ((strong ,text)
+ (format #f "@strong{~a}" text))
+ ((a (@ (href ,url)) ,text)
+ (format #f "@url{~a,~a}" url text))
+ ((code ,text)
+ (format #f "@code{~a}" text))
+ (,something-else something-else)))
(define (go-package-description name)
"Retrieve a short description for NAME, a Go package name,
e.g. \"google.golang.org/protobuf/proto\"."
(let* ((body (go.pkg.dev-info name))
- (sxml (html->sxml body))
+ (sxml (html->sxml body #:strict? #t))
(overview ((sxpath
`(//
(* (@ (equal? (class "Documentation-overview"))))
@@ -189,8 +190,9 @@ e.g. \"google.golang.org/protobuf/proto\"."
(description (if (not (null? overview))
overview
(select-content sxml)))
- (description* (and (not (null? description))
- (first description))))
+ (description* (if (not (null? description))
+ (first description)
+ description)))
(match description*
(() #f) ;nothing selected
((p elements ...)
@@ -209,7 +211,7 @@ the https://pkg.go.dev/ web site."
(select-title (sxpath
`(// (div (@ (equal? (class "UnitReadme-content"))))
// h3 *text*))))
- (match (select-title (html->sxml body))
+ (match (select-title (html->sxml body #:strict? #t))
(() #f) ;nothing selected
((title more ...) ;title is the first string of the list
(string-trim-both title)))))
@@ -245,128 +247,138 @@ and VERSION and return an input port."
(go-path-escape version))))
(http-fetch* url)))
-(define %go.mod-require-directive-rx
- ;; A line in a require directive is composed of a module path and
- ;; a version separated by whitespace and an optionnal '//' comment at
- ;; the end.
- (make-regexp
- (string-append
- "^[[:blank:]]*([^[:blank:]]+)[[:blank:]]+" ;the module path
- "([^[:blank:]]+)" ;the version
- "([[:blank:]]+//.*)?"))) ;an optional comment
-(define %go.mod-replace-directive-rx
+(define (parse-go.mod content)
+ "Parse the go.mod file CONTENT, returning a list of directives, comments,
+and unknown lines. Each sublist begins with a symbol (go, module, require,
+replace, exclude, retract, comment, or unknown) and is followed by one or more
+sublists. Each sublist begins with a symbol (module-path, version, file-path,
+comment, or unknown) and is followed by the indicated data."
+ ;; https://golang.org/ref/mod#go-mod-file-grammar
+ (define-peg-pattern NL none "\n")
+ (define-peg-pattern WS none (or " " "\t" "\r"))
+ (define-peg-pattern => none (and (* WS) "=>"))
+ (define-peg-pattern punctuation none (or "," "=>" "[" "]" "(" ")"))
+ (define-peg-pattern comment all
+ (and (ignore "//") (* WS) (* (and (not-followed-by NL) peg-any))))
+ (define-peg-pattern EOL body (and (* WS) (? comment) NL))
+ (define-peg-pattern block-start none (and (* WS) "(" EOL))
+ (define-peg-pattern block-end none (and (* WS) ")" EOL))
+ (define-peg-pattern any-line body
+ (and (* WS) (* (and (not-followed-by NL) peg-any)) EOL))
+
+ ;; Strings and identifiers
+ (define-peg-pattern identifier body
+ (+ (and (not-followed-by (or NL WS punctuation)) peg-any)))
+ (define-peg-pattern string-raw body
+ (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`")))
+ (define-peg-pattern string-quoted body
+ (and (ignore "\"")
+ (+ (or (and (ignore "\\") peg-any)
+ (and (not-followed-by "\"") peg-any)))
+ (ignore "\"")))
+ (define-peg-pattern string-or-ident body
+ (and (* WS) (or string-raw string-quoted identifier)))
+
+ (define-peg-pattern version all string-or-ident)
+ (define-peg-pattern module-path all string-or-ident)
+ (define-peg-pattern file-path all string-or-ident)
+
+ ;; Non-directive lines
+ (define-peg-pattern unknown all any-line)
+ (define-peg-pattern block-line body
+ (or EOL (and (not-followed-by block-end) unknown)))
+
+ ;; GoDirective = "go" GoVersion newline .
+ (define-peg-pattern go all (and (ignore "go") version EOL))
+
+ ;; ModuleDirective = "module" ( ModulePath | "(" newline ModulePath newline ")" ) newline .
+ (define-peg-pattern module all
+ (and (ignore "module") (or (and block-start module-path EOL block-end)
+ (and module-path EOL))))
+
+ ;; The following directives may all be used solo or in a block
+ ;; RequireSpec = ModulePath Version newline .
+ (define-peg-pattern require all (and module-path version EOL))
+ (define-peg-pattern require-top body
+ (and (ignore "require")
+ (or (and block-start (* (or require block-line)) block-end) require)))
+
+ ;; ExcludeSpec = ModulePath Version newline .
+ (define-peg-pattern exclude all (and module-path version EOL))
+ (define-peg-pattern exclude-top body
+ (and (ignore "exclude")
+ (or (and block-start (* (or exclude block-line)) block-end) exclude)))
+
;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline
;; | ModulePath [ Version ] "=>" ModulePath Version newline .
- (make-regexp
- (string-append
- "([^[:blank:]]+)" ;the module path
- "([[:blank:]]+([^[:blank:]]+))?" ;optional version
- "[[:blank:]]+=>[[:blank:]]+"
- "([^[:blank:]]+)" ;the file or module path
- "([[:blank:]]+([^[:blank:]]+))?"))) ;the version (if a module path)
+ (define-peg-pattern original all (or (and module-path version) module-path))
+ (define-peg-pattern with all (or (and module-path version) file-path))
+ (define-peg-pattern replace all (and original => with EOL))
+ (define-peg-pattern replace-top body
+ (and (ignore "replace")
+ (or (and block-start (* (or replace block-line)) block-end) replace)))
-(define (parse-go.mod content)
- "Parse the go.mod file CONTENT, returning a list of requirements."
- ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar
- ;; which we think necessary for our use case.
- (define (toplevel requirements replaced)
- "This is the main parser. The results are accumulated in THE REQUIREMENTS
-and REPLACED lists."
- (let ((line (read-line)))
- (cond
- ((eof-object? line)
- ;; parsing ended, give back the result
- (values requirements replaced))
- ((string=? line "require (")
- ;; a require block begins, delegate parsing to IN-REQUIRE
- (in-require requirements replaced))
- ((string=? line "replace (")
- ;; a replace block begins, delegate parsing to IN-REPLACE
- (in-replace requirements replaced))
- ((string-prefix? "require " line)
- ;; a require directive by itself
- (let* ((stripped-line (string-drop line 8)))
- (call-with-values
- (lambda ()
- (require-directive requirements replaced stripped-line))
- toplevel)))
- ((string-prefix? "replace " line)
- ;; a replace directive by itself
- (let* ((stripped-line (string-drop line 8)))
- (call-with-values
- (lambda ()
- (replace-directive requirements replaced stripped-line))
- toplevel)))
- (#t
- ;; unrecognised line, ignore silently
- (toplevel requirements replaced)))))
+ ;; RetractSpec = ( Version | "[" Version "," Version "]" ) newline .
+ (define-peg-pattern range all
+ (and (* WS) (ignore "[") version
+ (* WS) (ignore ",") version (* WS) (ignore "]")))
+ (define-peg-pattern retract all (and (or range version) EOL))
+ (define-peg-pattern retract-top body
+ (and (ignore "retract")
+ (or (and block-start (* (or retract block-line)) block-end) retract)))
- (define (in-require requirements replaced)
- (let ((line (read-line)))
- (cond
- ((eof-object? line)
- ;; this should never happen here but we ignore silently
- (values requirements replaced))
- ((string=? line ")")
- ;; end of block, coming back to toplevel
- (toplevel requirements replaced))
- (#t
- (call-with-values (lambda ()
- (require-directive requirements replaced line))
- in-require)))))
+ (define-peg-pattern go-mod body
+ (* (and (* WS) (or go module require-top exclude-top replace-top
+ retract-top EOL unknown))))
- (define (in-replace requirements replaced)
- (let ((line (read-line)))
- (cond
- ((eof-object? line)
- ;; this should never happen here but we ignore silently
- (values requirements replaced))
- ((string=? line ")")
- ;; end of block, coming back to toplevel
- (toplevel requirements replaced))
- (#t
- (call-with-values (lambda ()
- (replace-directive requirements replaced line))
- in-replace)))))
+ (let ((tree (peg:tree (match-pattern go-mod content)))
+ (keywords '(go module require replace exclude retract comment unknown)))
+ (keyword-flatten keywords tree)))
- (define (replace-directive requirements replaced line)
- "Extract replaced modules and new requirements from the replace directive
-in LINE and add them to the REQUIREMENTS and REPLACED lists."
- (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line))
- (module-path (match:substring rx-match 1))
- (version (match:substring rx-match 3))
- (new-module-path (match:substring rx-match 4))
- (new-version (match:substring rx-match 6))
- (new-replaced (cons (list module-path version) replaced))
- (new-requirements
- (if (string-match "^\\.?\\./" new-module-path)
- requirements
- (cons (list new-module-path new-version) requirements))))
- (values new-requirements new-replaced)))
+;; Prevent inlining of this procedure, which is accessed by unit tests.
+(set! parse-go.mod parse-go.mod)
+
+(define (go.mod-directives go.mod directive)
+ "Return the list of top-level directive bodies in GO.MOD matching the symbol
+DIRECTIVE."
+ (filter-map (match-lambda
+ (((? (cut eq? <> directive) head) . rest) rest)
+ (_ #f))
+ go.mod))
+
+(define (go.mod-requirements go.mod)
+ "Compute and return the list of requirements specified by GO.MOD."
+ (define (replace directive requirements)
+ (define (maybe-replace module-path new-requirement)
+ ;; Do not allow version updates for indirect dependencies (see:
+ ;; https://golang.org/ref/mod#go-mod-file-replace).
+ (if (and (equal? module-path (first new-requirement))
+ (not (assoc-ref requirements module-path)))
+ requirements
+ (cons new-requirement (alist-delete module-path requirements))))
+
+ (match directive
+ ((('original ('module-path module-path) . _) with . _)
+ (match with
+ (('with ('file-path _) . _)
+ (alist-delete module-path requirements))
+ (('with ('module-path new-module-path) ('version new-version) . _)
+ (maybe-replace module-path
+ (list new-module-path new-version)))))))
- (define (require-directive requirements replaced line)
- "Extract requirement from LINE and augment the REQUIREMENTS and REPLACED
-lists."
- (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line))
- (module-path (match:substring rx-match 1))
- ;; Double-quoted strings were seen in the wild without escape
- ;; sequences; trim the quotes to be on the safe side.
- (module-path (string-trim-both module-path #\"))
- (version (match:substring rx-match 2)))
- (values (cons (list module-path version) requirements) replaced)))
+ (define (require directive requirements)
+ (match directive
+ ((('module-path module-path) ('version version) . _)
+ (cons (list module-path version) requirements))))
- (with-input-from-string content
- (lambda ()
- (receive (requirements replaced)
- (toplevel '() '())
- ;; At last remove the replaced modules from the requirements list.
- (remove (lambda (r)
- (assoc (car r) replaced))
- requirements)))))
+ (let* ((requires (go.mod-directives go.mod 'require))
+ (replaces (go.mod-directives go.mod 'replace))
+ (requirements (fold require '() requires)))
+ (fold replace requirements replaces)))
;; Prevent inlining of this procedure, which is accessed by unit tests.
-(set! parse-go.mod parse-go.mod)
+(set! go.mod-requirements go.mod-requirements)
(define-record-type <vcs>
(%make-vcs url-prefix root-regex type)
@@ -381,28 +393,28 @@ lists."
(define known-vcs
;; See the following URL for the official Go equivalent:
;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087
- (list
- (make-vcs
- "github.com"
- "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "bitbucket.org"
- "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
- 'unknown)
- (make-vcs
- "hub.jazz.net/git/"
- "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "git.apache.org"
- "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "git.openstack.org"
- "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
+ (list
+ (make-vcs
+ "github.com"
+ "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "bitbucket.org"
+ "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
+ 'unknown)
+ (make-vcs
+ "hub.jazz.net/git/"
+ "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.apache.org"
+ "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.openstack.org"
+ "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
(/[A-Za-z0-9_.\\-]+)*$"
- 'git)))
+ 'git)))
(define (module-path->repository-root module-path)
"Infer the repository root from a module path. Go modules can be
@@ -431,9 +443,9 @@ hence the need to derive this information."
(define* (go-module->guix-package-name module-path #:optional version)
"Converts a module's path to the canonical Guix format for Go packages.
Optionally include a VERSION string to append to the name."
- ;; Map dot, slash and underscore characters to hyphens.
+ ;; Map dot, slash, underscore and tilde characters to hyphens.
(let ((module-path* (string-map (lambda (c)
- (if (member c '(#\. #\/ #\_))
+ (if (member c '(#\. #\/ #\_ #\~))
#\-
c))
module-path)))
@@ -461,17 +473,24 @@ Optionally include a VERSION string to append to the name."
"Retrieve the module meta-data from its landing page. This is necessary
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)
+ ((root-path vcs repo-url)
+ (make-module-meta root-path (string->symbol vcs)
+ (strip-.git-suffix/maybe repo-url)))))
;; <meta name="go-import" content="import-prefix vcs repo-root">
(let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
- (select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
+ (select (sxpath `(// (meta (@ (equal? (name "go-import"))))
// content))))
- (match (select (html->sxml meta-data))
+ (match (select (html->sxml meta-data #:strict? #t))
(() #f) ;nothing selected
- (((content content-text))
- (match (string-split content-text #\space)
- ((root-path vcs repo-url)
- (make-module-meta root-path (string->symbol vcs)
- (strip-.git-suffix/maybe repo-url))))))))
+ ((('content content-text) ..1)
+ (or
+ (find (lambda (meta)
+ (string-prefix? (module-meta-import-prefix meta) module-path))
+ (map go-import->module-meta content-text))
+ ;; Fallback to the first meta if no import prefixes match.
+ (go-import->module-meta (first content-text)))))))
(define (module-meta-data-repo-url meta-data goproxy)
"Return the URL where the fetcher which will be used can download the
@@ -589,7 +608,7 @@ When VERSION is unspecified, the latest version available is used."
hint: use one of the following available versions ~a\n"
version* available-versions))))
(content (fetch-go.mod goproxy module-path version*))
- (dependencies+versions (parse-go.mod content))
+ (dependencies+versions (go.mod-requirements (parse-go.mod content)))
(dependencies (if pin-versions?
dependencies+versions
(map car dependencies+versions)))
@@ -600,7 +619,7 @@ hint: use one of the following available versions ~a\n"
(meta-data (fetch-module-meta-data root-module-path))
(vcs-type (module-meta-vcs meta-data))
(vcs-repo-url (module-meta-data-repo-url meta-data goproxy))
- (synopsis (go-package-synopsis root-module-path))
+ (synopsis (go-package-synopsis module-path))
(description (go-package-description module-path))
(licenses (go-package-licenses module-path)))
(values
@@ -611,7 +630,10 @@ hint: use one of the following available versions ~a\n"
,(vcs->origin vcs-type vcs-repo-url version*))
(build-system go-build-system)
(arguments
- '(#:import-path ,root-module-path))
+ '(#:import-path ,module-path
+ ,@(if (string=? module-path root-module-path)
+ '()
+ `(#:unpack-path ,root-module-path))))
,@(maybe-propagated-inputs
(map (match-lambda
((name version)
@@ -632,7 +654,28 @@ hint: use one of the following available versions ~a\n"
dependencies+versions
dependencies))))
-(define go-module->guix-package* (memoize go-module->guix-package))
+(define go-module->guix-package*
+ (lambda args
+ ;; Disable output buffering so that the following warning gets printed
+ ;; consistently.
+ (setvbuf (current-error-port) 'none)
+ (let ((package-name (match args ((name _ ...) name))))
+ (guard (c ((http-get-error? c)
+ (warning (G_ "Failed to import package ~s.
+reason: ~s could not be fetched: HTTP error ~a (~s).
+This package and its dependencies won't be imported.~%")
+ package-name
+ (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)))))
(define* (go-module-recursive-import package-name
#:key (goproxy "https://proxy.golang.org")
@@ -642,23 +685,12 @@ hint: use one of the following available versions ~a\n"
(recursive-import
package-name
#:repo->guix-package
- (lambda* (name #:key version repo)
- ;; Disable output buffering so that the following warning gets printed
- ;; consistently.
- (setvbuf (current-error-port) 'none)
- (guard (c ((http-get-error? c)
- (warning (G_ "Failed to import package ~s.
-reason: ~s could not be fetched: HTTP error ~a (~s).
-This package and its dependencies won't be imported.~%")
- name
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
- (values '() '())))
- (receive (package-sexp dependencies)
- (go-module->guix-package* name #:goproxy goproxy
- #:version version
- #:pin-versions? pin-versions?)
- (values package-sexp dependencies))))
+ (memoize
+ (lambda* (name #:key version repo)
+ (receive (package-sexp dependencies)
+ (go-module->guix-package* name #:goproxy goproxy
+ #:version version
+ #:pin-versions? pin-versions?)
+ (values package-sexp dependencies))))
#:guix-name go-module->guix-package-name
#:version version))
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 9f992ffe8e..f94a1e7087 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2016 Nikita <nikita@n0.is>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -163,22 +164,22 @@ version."
;; https://www.haskell.org
;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
(match-lambda
- ("GPL-2" 'gpl2)
- ("GPL-3" 'gpl3)
+ ("GPL-2" 'license:gpl2)
+ ("GPL-3" 'license:gpl3)
("GPL" "'gpl??")
- ("AGPL-3" 'agpl3)
+ ("AGPL-3" 'license:agpl3)
("AGPL" "'agpl??")
- ("LGPL-2.1" 'lgpl2.1)
- ("LGPL-3" 'lgpl3)
+ ("LGPL-2.1" 'license:lgpl2.1)
+ ("LGPL-3" 'license:lgpl3)
("LGPL" "'lgpl??")
- ("BSD2" 'bsd-2)
- ("BSD3" 'bsd-3)
- ("BSD-3-Clause" 'bsd-3)
- ("MIT" 'expat)
- ("ISC" 'isc)
- ("MPL" 'mpl2.0)
- ("Apache-2.0" 'asl2.0)
- ("PublicDomain" 'public-domain)
+ ("BSD2" 'license:bsd-2)
+ ("BSD3" 'license:bsd-3)
+ ("BSD-3-Clause" 'license:bsd-3)
+ ("MIT" 'license:expat)
+ ("ISC" 'license:isc)
+ ("MPL" 'license:mpl2.0)
+ ("Apache-2.0" 'license:asl2.0)
+ ("PublicDomain" 'license:public-domain)
((x) (string->license x))
((lst ...) `(list ,@(map string->license lst)))
(_ #f)))
diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm
index fd3cfa8444..aeb447b0a5 100644
--- a/guix/import/launchpad.scm
+++ b/guix/import/launchpad.scm
@@ -1,5 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2021 Matthew James Kraai <kraai@ftbfs.org>
+;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -100,8 +102,8 @@ URL of the form
(match (string-split (uri-path (string->uri url)) #\/)
((_ repo . rest) repo)))
-(define (latest-released-version package-name)
- "Return a string of the newest released version name given the PACKAGE-NAME,
+(define (latest-released-version repository)
+ "Return a string of the newest released version name given the REPOSITORY,
for example, 'linuxdcpp'. Return #f if there is no releases."
(define (pre-release? x)
;; Versions containing anything other than digit characters and "." (for
@@ -110,27 +112,27 @@ for example, 'linuxdcpp'. Return #f if there is no releases."
char-set:digit)
(assoc-ref x "version"))))
- (assoc-ref
- (last (remove
- pre-release?
- (vector->list
- (assoc-ref (json-fetch
- (string-append "https://api.launchpad.net/1.0/"
- package-name "/releases"))
- "entries"))))
- "version"))
+ (match (json-fetch
+ (string-append "https://api.launchpad.net/1.0/"
+ repository "/releases"))
+ (#f #f) ;404 or similar
+ (json
+ (assoc-ref
+ (last (remove pre-release? (vector->list (assoc-ref json "entries"))))
+ "version"))))
(define (latest-release pkg)
"Return an <upstream-source> for the latest release of PKG."
- (define (origin-github-uri origin)
+ (define (origin-launchpad-uri origin)
(match (origin-uri origin)
((? string? url) url) ; surely a Launchpad URL
((urls ...)
(find (cut string-contains <> "launchpad.net") urls))))
- (let* ((source-uri (origin-github-uri (package-source pkg)))
+ (let* ((source-uri (origin-launchpad-uri (package-source pkg)))
(name (package-name pkg))
- (newest-version (latest-released-version name)))
+ (repository (launchpad-repository source-uri))
+ (newest-version (latest-released-version repository)))
(if newest-version
(upstream-source
(package name)
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
new file mode 100644
index 0000000000..ba86c60bfd
--- /dev/null
+++ b/guix/import/minetest.scm
@@ -0,0 +1,468 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import minetest)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 threads)
+ #:use-module (ice-9 hash-table)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (guix utils)
+ #:use-module (guix ui)
+ #:use-module (guix i18n)
+ #:use-module (guix memoization)
+ #:use-module (guix serialization)
+ #:use-module (guix import utils)
+ #:use-module (guix import json)
+ #:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256))
+ #:use-module (json)
+ #:use-module (guix base32)
+ #:use-module (guix git)
+ #:use-module (guix store)
+ #:export (%default-sort-key
+ %contentdb-api
+ json->package
+ contentdb-fetch
+ elaborate-contentdb-name
+ minetest->guix-package
+ minetest-recursive-import
+ sort-packages))
+
+;; The ContentDB API is documented at
+;; <https://content.minetest.net>.
+
+(define %contentdb-api
+ (make-parameter "https://content.minetest.net/api/"))
+
+(define (string-or-false x)
+ (and (string? x) x))
+
+(define (natural-or-false x)
+ (and (exact-integer? x) (>= x 0) x))
+
+;; Descriptions on ContentDB use carriage returns, but Guix doesn't.
+(define (delete-cr text)
+ (string-delete #\cr text))
+
+
+
+;;;
+;;; JSON mappings
+;;;
+
+;; Minetest package.
+;;
+;; API endpoint: /packages/AUTHOR/NAME/
+(define-json-mapping <package> make-package package?
+ json->package
+ (author package-author) ; string
+ (creation-date package-creation-date ; string
+ "created_at")
+ (downloads package-downloads) ; integer
+ (forums package-forums "forums" natural-or-false)
+ (issue-tracker package-issue-tracker "issue_tracker") ; string
+ (license package-license) ; string
+ (long-description package-long-description "long_description") ; string
+ (maintainers package-maintainers ; list of strings
+ "maintainers" vector->list)
+ (media-license package-media-license "media_license") ; string
+ (name package-name) ; string
+ (provides package-provides ; list of strings
+ "provides" vector->list)
+ (release package-release) ; integer
+ (repository package-repository "repo" string-or-false)
+ (score package-score) ; flonum
+ (screenshots package-screenshots "screenshots" vector->list) ; list of strings
+ (short-description package-short-description "short_description") ; string
+ (state package-state) ; string
+ (tags package-tags "tags" vector->list) ; list of strings
+ (thumbnail package-thumbnail) ; string
+ (title package-title) ; string
+ (type package-type) ; string
+ (url package-url) ; string
+ (website package-website "website" string-or-false))
+
+(define-json-mapping <release> make-release release?
+ json->release
+ ;; If present, a git commit identified by its hash
+ (commit release-commit "commit" string-or-false)
+ (downloads release-downloads) ; integer
+ (id release-id) ; integer
+ (max-minetest-version release-max-minetest-version string-or-false)
+ (min-minetest-version release-min-minetest-version string-or-false)
+ (release-date release-data) ; string
+ (title release-title) ; string
+ (url release-url)) ; string
+
+(define-json-mapping <dependency> make-dependency dependency?
+ json->dependency
+ (optional? dependency-optional? "is_optional") ; bool
+ (name dependency-name) ; string
+ (packages dependency-packages "packages" vector->list)) ; list of strings
+
+;; A structure returned by the /api/packages/?fmt=keys endpoint
+(define-json-mapping <package-keys> make-package-keys package-keys?
+ json->package-keys
+ (author package-keys-author) ; string
+ (name package-keys-name) ; string
+ (type package-keys-type)) ; string
+
+(define (package-mod? package)
+ "Is the ContentDB package PACKAGE a mod?"
+ ;; ContentDB also has ‘games’ and ‘texture packs’.
+ (string=? (package-type package) "mod"))
+
+
+
+;;;
+;;; Manipulating names of packages
+;;;
+;;; There are three kind of names:
+;;;
+;;; * names of guix packages, e.g. minetest-basic-materials.
+;;; * names of mods on ContentDB, e.g. basic_materials
+;;; * a combination of author and mod name on ContentDB, e.g. VanessaE/basic_materials
+;;;
+
+(define (%construct-full-name author name)
+ (string-append author "/" name))
+
+(define (package-full-name package)
+ "Given a <package> object, return the corresponding AUTHOR/NAME string."
+ (%construct-full-name (package-author package) (package-name package)))
+
+(define (package-keys-full-name package)
+ "Given a <package-keys> object, return the corresponding AUTHOR/NAME string."
+ (%construct-full-name (package-keys-author package)
+ (package-keys-name package)))
+
+(define (contentdb->package-name author/name)
+ "Given the AUTHOR/NAME of a package on ContentDB, return a Guix-compliant
+name for the package."
+ ;; The author is not included, as the names of popular mods
+ ;; tend to be unique.
+ (string-append "minetest-" (snake-case (author/name->name author/name))))
+
+(define (author/name->name author/name)
+ "Extract NAME from the AUTHOR/NAME string, or raise an error if AUTHOR/NAME
+is ill-formatted."
+ (match (string-split author/name #\/)
+ ((author name)
+ (when (string-null? author)
+ (leave
+ (G_ "In ~a: author names must consist of at least a single character.~%")
+ author/name))
+ (when (string-null? name)
+ (leave
+ (G_ "In ~a: mod names must consist of at least a single character.~%")
+ author/name))
+ name)
+ ((too many . components)
+ (leave
+ (G_ "In ~a: author names and mod names may not contain forward slashes.~%")
+ author/name))
+ ((name)
+ (if (string-null? name)
+ (leave (G_ "mod names may not be empty.~%"))
+ (leave (G_ "The name of the author is missing in ~a.~%")
+ author/name)))))
+
+(define* (elaborate-contentdb-name name #:key (sort %default-sort-key))
+ "If NAME is an AUTHOR/NAME string, return it. Otherwise, try to determine
+the author and return an appropriate AUTHOR/NAME string. If that fails,
+raise an exception."
+ (if (or (string-contains name "/") (string-null? name))
+ ;; Call 'author/name->name' to verify that NAME seems reasonable
+ ;; and raise an appropriate exception if it isn't.
+ (begin
+ (author/name->name name)
+ name)
+ (let* ((package-keys (contentdb-query-packages name #:sort sort))
+ (correctly-named
+ (filter (lambda (package-key)
+ (string=? name (package-keys-name package-key)))
+ package-keys)))
+ (match correctly-named
+ ((one) (package-keys-full-name one))
+ ((too . many)
+ (warning (G_ "~a is ambiguous, presuming ~a (other options include: ~a)~%")
+ name (package-keys-full-name too)
+ (map package-keys-full-name many))
+ (package-keys-full-name too))
+ (()
+ (leave (G_ "No mods with name ~a were found.~%") name))))))
+
+
+
+;;;
+;;; API endpoints
+;;;
+
+(define contentdb-fetch
+ (mlambda (author/name)
+ "Return a <package> record for package AUTHOR/NAME, or #f on failure."
+ (and=> (json-fetch
+ (string-append (%contentdb-api) "packages/" author/name "/"))
+ json->package)))
+
+(define (contentdb-fetch-releases author/name)
+ "Return a list of <release> records for package NAME by AUTHOR, or #f
+on failure."
+ (and=> (json-fetch (string-append (%contentdb-api) "packages/" author/name
+ "/releases/"))
+ (lambda (json)
+ (map json->release (vector->list json)))))
+
+(define (latest-release author/name)
+ "Return the latest source release for package NAME by AUTHOR,
+or #f if this package does not exist."
+ (and=> (contentdb-fetch-releases author/name)
+ car))
+
+(define (contentdb-fetch-dependencies author/name)
+ "Return an alist of lists of <dependency> records for package NAME by AUTHOR
+and possibly some other packages as well, or #f on failure."
+ (define url (string-append (%contentdb-api) "packages/" author/name
+ "/dependencies/"))
+ (and=> (json-fetch url)
+ (lambda (json)
+ (map (match-lambda
+ ((key . value)
+ (cons key (map json->dependency (vector->list value)))))
+ json))))
+
+(define* (contentdb-query-packages q #:key
+ (type "mod")
+ (limit 50)
+ (sort %default-sort-key)
+ (order "desc"))
+ "Search ContentDB for Q (a string). Sort by SORT, in ascending order
+if ORDER is \"asc\" or descending order if ORDER is \"desc\". TYPE must
+be \"mod\", \"game\" or \"txp\", restricting the search results to
+respectively mods, games and texture packs. Limit to at most LIMIT
+results. The return value is a list of <package-keys> records."
+ ;; XXX does Guile have something for constructing (and, when necessary,
+ ;; escaping) query strings?
+ (define url (string-append (%contentdb-api) "packages/?type=" type
+ "&q=" q "&fmt=keys"
+ "&limit=" (number->string limit)
+ "&order=" order
+ "&sort=" sort))
+ (let ((json (json-fetch url)))
+ (if json
+ (map json->package-keys (vector->list json))
+ (leave
+ (G_ "The package search API doesn't exist anymore.~%")))))
+
+
+
+;; XXX copied from (guix import elpa)
+(define* (download-git-repository url ref)
+ "Fetch the given REF from the Git repository at URL."
+ (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)
+ "Return a S-expression for the minetest package with the given author/NAME,
+VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
+MEDIA-LICENSE and LICENSE."
+ `(package
+ (name ,(contentdb->package-name author/name))
+ (version ,version)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,repository)
+ (commit ,commit)))
+ (sha256
+ (base32
+ ;; The git commit is not always available.
+ ,(and commit
+ (bytevector->nix-base32-string
+ (file-hash
+ (download-git-repository repository
+ `(commit . ,commit)))))))
+ (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))
+ (license ,(if (eq? media-license license)
+ license
+ `(list ,media-license ,license)))
+ ;; The Minetest updater (not yet in Guix; it requires not-yet-submitted
+ ;; patches to (guix upstream) that require some work) needs to know both
+ ;; the author name and mod name for efficiency.
+ (properties ,(list 'quasiquote `((upstream-name . ,author/name))))))
+
+(define (package-home-page package)
+ "Guess the home page of the ContentDB package PACKAGE.
+
+In order of preference, try the 'website', the forum topic on the
+official Minetest forum and the Git repository (if any)."
+ (define (topic->url-sexp topic)
+ ;; 'minetest-topic' is a procedure defined in (gnu packages minetest)
+ `(minetest-topic ,topic))
+ (or (package-website package)
+ (and=> (package-forums package) topic->url-sexp)
+ (package-repository package)))
+
+(define (release-version release)
+ "Guess the version of RELEASE from the release title."
+ (define title (release-title release))
+ (if (string-prefix? "v" title)
+ ;; Remove "v" prefix from release titles like ‘v1.0.1’.
+ (substring title 1)
+ title))
+
+;; 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")
+
+(define* (sort-packages packages #:key (sort %default-sort-key))
+ "Sort PACKAGES by SORT, in descending order."
+ (define package->key
+ (match sort
+ ("score" package-score)
+ ("downloads" package-downloads)))
+ (define (greater x y)
+ (> (package->key x) (package->key y)))
+ (sort-list packages greater))
+
+(define builtin-mod?
+ (let ((%builtin-mods
+ (alist->hash-table
+ (map (lambda (x) (cons x #t))
+ '("beds" "binoculars" "boats" "bones" "bucket" "butterflies"
+ "carts" "creative" "default" "doors" "dungeon_loot" "dye"
+ "env_sounds" "farming" "fire" "fireflies" "flowers"
+ "game_commands" "give_initial_stuff" "map" "mtg_craftguide"
+ "player_api" "screwdriver" "sethome" "sfinv" "spawn" "stairs"
+ "tnt" "vessels" "walls" "weather" "wool" "xpanes")))))
+ (lambda (mod)
+ "Is MOD provided by the default minetest subgame?"
+ (hash-ref %builtin-mods mod))))
+
+(define* (important-dependencies dependencies author/name
+ #:key (sort %default-sort-key))
+ "Return the hard dependencies of AUTHOR/NAME in the association list
+DEPENDENCIES as a list of AUTHOR/NAME strings."
+ (define dependency-list
+ (assoc-ref dependencies author/name))
+ ;; A mod can have multiple dependencies implemented by the same mod,
+ ;; so remove duplicate mod names.
+ (define (filter-deduplicate-map f list)
+ (delete-duplicates (filter-map f list)))
+ (filter-deduplicate-map
+ (lambda (dependency)
+ (and (not (dependency-optional? dependency))
+ (not (builtin-mod? (dependency-name dependency)))
+ ;; The dependency information contains symbolic names
+ ;; that can be ‘provided’ by multiple mods, so we need to choose one
+ ;; of the implementations.
+ (let* ((implementations
+ (par-map contentdb-fetch (dependency-packages dependency)))
+ ;; Fetching package information about the packages is racy:
+ ;; some packages might be removed from ContentDB between the
+ ;; construction of DEPENDENCIES and the call to
+ ;; 'contentdb-fetch'. So filter out #f.
+ ;;
+ ;; Filter out ‘games’ that include the requested mod -- it's
+ ;; the mod itself we want.
+ (mods (filter (lambda (p) (and=> p package-mod?))
+ implementations))
+ (sorted-mods (sort-packages mods #:sort sort)))
+ (match sorted-mods
+ ((package) (package-full-name package))
+ ((too . many)
+ (warning
+ (G_ "The dependency ~a of ~a has multiple different implementations ~a.~%")
+ (dependency-name dependency)
+ author/name
+ (map package-full-name sorted-mods))
+ (match sort
+ ("score"
+ (warning
+ (G_ "The implementation with the highest score will be choosen!~%")))
+ ("downloads"
+ (warning
+ (G_ "The implementation that has been downloaded the most will be choosen!~%"))))
+ (package-full-name too))
+ (()
+ (warning
+ (G_ "The dependency ~a of ~a does not have any implementation. It will be ignored!~%")
+ (dependency-name dependency) author/name)
+ #f)))))
+ dependency-list))
+
+(define* (%minetest->guix-package author/name #:key (sort %default-sort-key))
+ "Fetch the metadata for AUTHOR/NAME from https://content.minetest.net, and
+return the 'package' S-expression corresponding to that package, or raise an
+exception on failure. On success, also return the upstream dependencies as a
+list of AUTHOR/NAME strings."
+ ;; Call 'author/name->name' to verify that AUTHOR/NAME seems reasonable.
+ (author/name->name author/name)
+ (define package (contentdb-fetch author/name))
+ (unless package
+ (leave (G_ "no package metadata for ~a on ContentDB~%") author/name))
+ (define dependencies (contentdb-fetch-dependencies author/name))
+ (unless dependencies
+ (leave (G_ "no dependency information for ~a on ContentDB~%") author/name))
+ (define release (latest-release author/name))
+ (unless release
+ (leave (G_ "no release of ~a on ContentDB~%") author/name))
+ (define important-upstream-dependencies
+ (important-dependencies dependencies author/name #:sort sort))
+ (values (make-minetest-sexp author/name
+ (release-version release)
+ (package-repository package)
+ (release-commit release)
+ important-upstream-dependencies
+ (package-home-page package)
+ (package-short-description package)
+ (package-long-description package)
+ (spdx-string->license
+ (package-media-license package))
+ (spdx-string->license
+ (package-license package)))
+ important-upstream-dependencies))
+
+(define minetest->guix-package
+ (memoize %minetest->guix-package))
+
+(define* (minetest-recursive-import author/name #:key (sort %default-sort-key))
+ (define* (minetest->guix-package* author/name #:key repo version)
+ (minetest->guix-package author/name #:sort sort))
+ (recursive-import author/name
+ #:repo->guix-package minetest->guix-package*
+ #:guix-name contentdb->package-name))
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 670973b193..fe13d29f03 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -1,6 +1,8 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Alice Brenon <alice.brenon@ens-lyon.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,21 +23,24 @@
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 peg)
+ #:use-module ((ice-9 popen) #:select (open-pipe*))
#:use-module (ice-9 receive)
- #:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
- #:use-module (web uri)
+ #:use-module ((srfi srfi-26) #:select (cut))
+ #:use-module ((web uri) #:select (string->uri uri->string))
+ #:use-module ((guix build utils) #:select (dump-port find-files mkdir-p))
#:use-module (guix build-system)
#:use-module (guix build-system ocaml)
#:use-module (guix http-client)
- #:use-module (guix git)
#:use-module (guix ui)
#:use-module (guix packages)
#:use-module (guix upstream)
- #:use-module (guix utils)
+ #:use-module ((guix utils) #:select (cache-directory
+ version>?
+ call-with-temporary-output-file))
#:use-module (guix import utils)
#:use-module ((guix licenses) #:prefix license:)
#:export (opam->guix-package
@@ -65,7 +70,7 @@
(range #\# #\頋)))
(define-peg-pattern operator all (or "=" "!" "<" ">"))
-(define-peg-pattern records body (* (and (or record weird-record) (* SP))))
+(define-peg-pattern records body (and (* SP) (* (and (or record weird-record) (* SP)))))
(define-peg-pattern record all (and key COLON (* SP) value))
(define-peg-pattern weird-record all (and key (* SP) dict))
(define-peg-pattern key body (+ (or (range #\a #\z) "-")))
@@ -120,51 +125,83 @@
(define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
-(define* (get-opam-repository #:optional repo)
+(define (opam-cache-directory path)
+ (string-append (cache-directory) "/opam/" path))
+
+(define known-repositories
+ '((opam . "https://opam.ocaml.org")
+ (coq . "https://coq.inria.fr/opam/released")
+ (coq-released . "https://coq.inria.fr/opam/released")
+ (coq-core-dev . "https://coq.inria.fr/opam/core-dev")
+ (coq-extra-dev . "https://coq.inria.fr/opam/extra-dev")
+ (grew . "http://opam.grew.fr")))
+
+(define (get-uri repo-root)
+ (let ((archive-file (string-append repo-root "/index.tar.gz")))
+ (or (string->uri archive-file)
+ (begin
+ (warning (G_ "'~a' is not a valid URI~%") archive-file)
+ 'bad-repo))))
+
+(define (repo-type repo)
+ (match (assoc-ref known-repositories (string->symbol repo))
+ (#f (if (file-exists? repo)
+ `(local ,repo)
+ `(remote ,(get-uri repo))))
+ (url `(remote ,(get-uri url)))))
+
+(define (update-repository input)
+ "Make sure the cache for opam repository INPUT is up-to-date"
+ (let* ((output (opam-cache-directory (basename (port-filename input))))
+ (cached-date (if (file-exists? output)
+ (stat:mtime (stat output))
+ (begin (mkdir-p output) 0))))
+ (when (> (stat:mtime (stat input)) cached-date)
+ (call-with-port
+ (open-pipe* OPEN_WRITE "tar" "xz" "-C" output "-f" "-")
+ (cut dump-port input <>)))
+ output))
+
+(define* (get-opam-repository #:optional (repo "opam"))
"Update or fetch the latest version of the opam repository and return the
path to the repository."
- (let ((url (cond
- ((or (not repo) (equal? repo 'opam))
- "https://github.com/ocaml/opam-repository")
- ((string-prefix? "coq-" (symbol->string repo))
- "https://github.com/coq/opam-coq-archive")
- ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive")
- (else (throw 'unknown-repository repo)))))
- (receive (location commit _)
- (update-cached-checkout url)
- (cond
- ((or (not repo) (equal? repo 'opam))
- location)
- ((equal? repo 'coq)
- (string-append location "/released"))
- ((string-prefix? "coq-" (symbol->string repo))
- (string-append location "/" (substring (symbol->string repo) 4)))
- (else location)))))
+ (match (repo-type repo)
+ (('local p) p)
+ (('remote 'bad-repo) #f) ; to weed it out during filter-map in opam-fetch
+ (('remote r) (call-with-port (http-fetch/cached r) update-repository))))
;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
(set! get-opam-repository get-opam-repository)
-(define (latest-version versions)
- "Find the most recent version from a list of versions."
- (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
+(define (get-version-and-file path)
+ "Analyse a candidate path and return an list containing information for proper
+ version comparison as well as the source path for metadata."
+ (and-let* ((metadata-file (string-append path "/opam"))
+ (filename (basename path))
+ (version (string-join (cdr (string-split filename #\.)) ".")))
+ (and (file-exists? metadata-file)
+ (eq? 'regular (stat:type (stat metadata-file)))
+ (if (string-prefix? "v" version)
+ `(V ,(substring version 1) ,metadata-file)
+ `(digits ,version ,metadata-file)))))
+
+(define (keep-max-version a b)
+ "Version comparison on the lists returned by the previous function taking the
+ janestreet re-versioning into account (v-prefixed come first)."
+ (match (cons a b)
+ ((('V va _) . ('V vb _)) (if (version>? va vb) a b))
+ ((('V _ _) . _) a)
+ ((_ . ('V _ _)) b)
+ ((('digits va _) . ('digits vb _)) (if (version>? va vb) a b))))
(define (find-latest-version package repository)
"Get the latest version of a package as described in the given repository."
- (let* ((dir (string-append repository "/packages/" package))
- (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
- (if versions
- (let ((versions (map
- (lambda (dir)
- (string-join (cdr (string-split dir #\.)) "."))
- versions)))
- ;; Workaround for janestreet re-versionning
- (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
- (if (null? v-versions)
- (latest-version versions)
- (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
- (begin
- (format #t (G_ "Package not found in opam repository: ~a~%") package)
- #f))))
+ (let ((packages (string-append repository "/packages"))
+ (filter (make-regexp (string-append "^" package "\\."))))
+ (reduce keep-max-version #f
+ (filter-map
+ get-version-and-file
+ (find-files packages filter #:directories? #t)))))
(define (get-metadata opam-file)
(with-input-from-file opam-file
@@ -265,28 +302,30 @@ path to the repository."
(define (depends->native-inputs depends)
(filter (lambda (name) (not (equal? "" name)))
- (map dependency->native-input depends)))
+ (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)))
+ (lambda (dependency)
+ (list dependency (list 'unquote (string->symbol dependency))))
+ (ocaml-names->guix-names lst)))
-(define* (opam-fetch name #:optional (repository (get-opam-repository)))
- (and-let* ((repository repository)
- (version (find-latest-version name repository))
- (file (string-append repository "/packages/" name "/" name "." version "/opam")))
- `(("metadata" ,@(get-metadata file))
- ("version" . ,(if (string-prefix? "v" version)
- (substring version 1)
- version)))))
+(define* (opam-fetch name #:optional (repositories-specs '("opam")))
+ (or (fold (lambda (repository others)
+ (match (find-latest-version name repository)
+ ((_ version file) `(("metadata" ,@(get-metadata file))
+ ("version" . ,version)))
+ (_ others)))
+ #f
+ (filter-map get-opam-repository repositories-specs))
+ (leave (G_ "package '~a' not found~%") name)))
-(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
+(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
or #f on failure."
- (and-let* ((opam-file (opam-fetch name (get-opam-repository repo)))
+ (and-let* ((with-opam (if (member "opam" repo) repo (cons "opam" repo)))
+ (opam-file (opam-fetch name with-opam))
(version (assoc-ref opam-file "version"))
(opam-content (assoc-ref opam-file "metadata"))
(url-dict (metadata-ref opam-content "url"))
@@ -311,9 +350,7 @@ or #f on failure."
(values
`(package
(name ,(ocaml-name->guix-name name))
- (version ,(if (string-prefix? "v" version)
- (substring version 1)
- version))
+ (version ,version)
(source
(origin
(method url-fetch)
@@ -335,7 +372,8 @@ or #f on failure."
(home-page ,(metadata-ref opam-content "homepage"))
(synopsis ,(metadata-ref opam-content "synopsis"))
(description ,(metadata-ref opam-content "description"))
- (license #f))
+ (license ,(spdx-string->license
+ (metadata-ref opam-content "license"))))
(filter
(lambda (name)
(not (member name '("dune" "jbuilder"))))
diff --git a/guix/import/print.scm b/guix/import/print.scm
index dcc38abc70..0310739b3a 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -60,9 +60,9 @@ when evaluated."
(if var
(symbol-append 'license: var)
`(license
- (name ,(license-name lic))
- (uri ,(license-uri lic))
- (comment ,(license-comment lic))))))
+ ,(license-name lic)
+ ,(license-uri lic)
+ ,(license-comment lic)))))
(define (search-path-specification->code spec)
`(search-path-specification
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index bf4dc50138..b7859c8341 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -9,6 +9,7 @@
;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -163,12 +164,13 @@ package on PyPI."
(hyphen-package-name->name+version
(basename (file-sans-extension url))))
- (match (and=> (package-source package) origin-uri)
- ((? string? url)
- (url->pypi-name url))
- ((lst ...)
- (any url->pypi-name lst))
- (#f #f)))
+ (or (assoc-ref (package-properties package) 'upstream-name)
+ (match (and=> (package-source package) origin-uri)
+ ((? string? url)
+ (url->pypi-name url))
+ ((lst ...)
+ (any url->pypi-name lst))
+ (#f #f))))
(define (wheel-url->extracted-directory wheel-url)
(match (string-split (basename wheel-url) #\-)
@@ -229,8 +231,8 @@ the input field."
'("test" "dev")))
(define (parse-requires.txt requires.txt)
- "Given REQUIRES.TXT, a Setuptools requires.txt file, return a list of lists
-of requirements.
+ "Given REQUIRES.TXT, a path to a Setuptools requires.txt file, return a list
+of lists of requirements.
The first list contains the required dependencies while the second the
optional test dependencies. Note that currently, optional, non-test
@@ -423,6 +425,11 @@ return the unaltered list of upstream dependency names."
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 (maybe-upstream-name name)
+ (if (string-match ".*\\-[0-9]+" (pk name))
+ `((properties ,`'(("upstream-name" . ,name))))
+ '()))
+
(call-with-temporary-output-file
(lambda (temp port)
(and (url-fetch source-url temp)
@@ -461,6 +468,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(sha256
(base32
,(guix-hash-url temp)))))
+ ,@(maybe-upstream-name name)
(build-system python-build-system)
,@(maybe-inputs required-inputs 'propagated-inputs)
,@(maybe-inputs native-inputs 'native-inputs)
diff --git a/guix/import/snix.scm b/guix/import/snix.scm
deleted file mode 100644
index 56934e8cf9..0000000000
--- a/guix/import/snix.scm
+++ /dev/null
@@ -1,467 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix import snix)
- #:use-module (sxml ssax)
- #:use-module (ice-9 popen)
- #:use-module (ice-9 match)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 format)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-37)
- #:use-module (system foreign)
- #:use-module (rnrs bytevectors)
-
- ;; Use the 'package-name->name+version' procedure that works with
- ;; hyphen-separate name/version, not the one that works with '@'-separated
- ;; name/version. Subtle!
- #:use-module ((guix utils) #:hide (package-name->name+version))
- #:use-module ((guix build utils) #:select (package-name->name+version))
-
- #:use-module (guix import utils)
- #:use-module (guix base16)
- #:use-module (guix base32)
- #:use-module (guix config)
- #:use-module (guix gnu-maintenance)
- #:export (open-nixpkgs
- xml->snix
- nixpkgs->guix-package))
-
-;;; Commentary:
-;;;
-;;; Converting Nix code to s-expressions, and then to Guix `package'
-;;; declarations, using the XML output of `nix-instantiate'.
-;;;
-;;; Code:
-
-
-;;;
-;;; SNix.
-;;;
-
-;; Nix object types visible in the XML output of `nix-instantiate' and
-;; mapping to S-expressions (we map to sexps, not records, so that we
-;; can do pattern matching):
-;;
-;; at (at varpat attrspat)
-;; attr (attribute loc name value)
-;; attrs (attribute-set attributes)
-;; attrspat (attribute-set-pattern patterns)
-;; bool #f|#t
-;; derivation (derivation drv-path out-path attributes)
-;; ellipsis '...
-;; expr (snix loc body ...)
-;; function (function loc at|attrspat|varpat)
-;; int int
-;; list list
-;; null 'null
-;; path string
-;; string string
-;; unevaluated 'unevaluated
-;; varpat (varpat name)
-;;
-;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
-;; however, handling `repeated' nodes makes it impossible to do anything
-;; lazily because the whole SXML tree has to be traversed to maintain the
-;; list of known derivations.
-
-(define (xml-element->snix elem attributes body derivations)
- "Return an SNix element corresponding to XML element ELEM."
-
- (define (loc)
- (location (assq-ref attributes 'path)
- (assq-ref attributes 'line)
- (assq-ref attributes 'column)))
-
- (case elem
- ((at)
- (values `(at ,(car body) ,(cadr body)) derivations))
- ((attr)
- (let ((name (assq-ref attributes 'name)))
- (cond ((null? body)
- (values `(attribute-pattern ,name) derivations))
- ((and (pair? body) (null? (cdr body)))
- (values `(attribute ,(loc) ,name ,(car body))
- derivations))
- (else
- (error "invalid attribute body" name (loc) body)))))
- ((attrs)
- (values `(attribute-set ,(reverse body)) derivations))
- ((attrspat)
- (values `(attribute-set-pattern ,body) derivations))
- ((bool)
- (values (string-ci=? "true" (assq-ref attributes 'value))
- derivations))
- ((derivation)
- (let ((drv-path (assq-ref attributes 'drvPath))
- (out-path (assq-ref attributes 'outPath)))
- (if (equal? body '(repeated))
- (let ((body (vhash-assoc drv-path derivations)))
- (if (pair? body)
- (values `(derivation ,drv-path ,out-path ,(cdr body))
- derivations)
-
- ;; DRV-PATH hasn't been encountered yet but may be later
- ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
- ;; Return an `unresolved' node.
- (values `(unresolved
- ,(lambda (derivations)
- (let ((body (vhash-assoc drv-path derivations)))
- (if (pair? body)
- `(derivation ,drv-path ,out-path
- ,(cdr body))
- (error "no previous occurrence of derivation"
- drv-path)))))
- derivations)))
- (values `(derivation ,drv-path ,out-path ,body)
- (vhash-cons drv-path body derivations)))))
- ((ellipsis)
- (values '... derivations))
- ((expr)
- (values `(snix ,(loc) ,@body) derivations))
- ((function)
- (values `(function ,(loc) ,body) derivations))
- ((int)
- (values (string->number (assq-ref attributes 'value))
- derivations))
- ((list)
- (values body derivations))
- ((null)
- (values 'null derivations))
- ((path)
- (values (assq-ref attributes 'value) derivations))
- ((repeated)
- (values 'repeated derivations))
- ((string)
- (values (assq-ref attributes 'value) derivations))
- ((unevaluated)
- (values 'unevaluated derivations))
- ((varpat)
- (values `(varpat ,(assq-ref attributes 'name)) derivations))
- (else (error "unhandled Nix XML element" elem))))
-
-(define (resolve snix derivations)
- "Return a new SNix tree where `unresolved' nodes from SNIX have been
-replaced by the result of their application to DERIVATIONS, a vhash."
- (let loop ((node snix)
- (seen vlist-null))
- (if (vhash-assq node seen)
- (values node seen)
- (match node
- (('unresolved proc)
- (let ((n (proc derivations)))
- (values n seen)))
- ((tag body ...)
- (let ((body+seen (fold (lambda (n body+seen)
- (call-with-values
- (lambda ()
- (loop n (cdr body+seen)))
- (lambda (n* seen)
- (cons (cons n* (car body+seen))
- (vhash-consq n #t seen)))))
- (cons '() (vhash-consq node #t seen))
- body)))
- (values (cons tag (reverse (car body+seen)))
- (vhash-consq node #t (cdr body+seen)))))
- (anything
- (values anything seen))))))
-
-(define xml->snix
- (let ((parse
- (ssax:make-parser NEW-LEVEL-SEED
- (lambda (elem-gi attributes namespaces expected-content
- seed)
- (cons '() (cdr seed)))
-
- FINISH-ELEMENT
- (lambda (elem-gi attributes namespaces parent-seed
- seed)
- (let ((snix (car seed))
- (derivations (cdr seed)))
- (let-values (((snix derivations)
- (xml-element->snix elem-gi
- attributes
- snix
- derivations)))
- (cons (cons snix (car parent-seed))
- derivations))))
-
- CHAR-DATA-HANDLER
- (lambda (string1 string2 seed)
- ;; Discard inter-node strings, which are blanks.
- seed))))
- (lambda (port)
- "Return the SNix represention of TREE, an SXML tree as returned by
-parsing the XML output of `nix-instantiate' on Nixpkgs."
- (match (parse port (cons '() vlist-null))
- (((snix) . derivations)
- (resolve snix derivations))))))
-
-(define (attribute-value attribute)
- "Return the value of ATTRIBUTE."
- (match attribute
- (('attribute _ _ value) value)))
-
-(define (derivation-source derivation)
- "Return the \"src\" attribute of DERIVATION or #f if not found."
- (match derivation
- (('derivation _ _ (attributes ...))
- (find-attribute-by-name "src" attributes))))
-
-(define (derivation-output-path derivation)
- "Return the output path of DERIVATION."
- (match derivation
- (('derivation _ out-path _)
- out-path)
- (_ #f)))
-
-(define (source-output-path src)
- "Return the output path of SRC, the \"src\" attribute of a derivation."
- (derivation-output-path (attribute-value src)))
-
-(define (source-urls src)
- "Return the URLs of SRC, the \"src\" attribute of a derivation."
- (match src
- (('attribute _ _ ('derivation _ _ (attributes ...)))
- (match (find-attribute-by-name "urls" attributes)
- (('attribute _ _ value)
- value)))
- (_ #f)))
-
-(define (source-sha256 src)
- "Return the sha256 of SRC, the \"src\" attribute of a derivation, as a
-bytevector."
- (match src
- (('attribute _ _ ('derivation _ _ (attributes ...)))
- (match (find-attribute-by-name "outputHash" attributes)
- (('attribute _ _ value)
- (match value
- ((= string-length 52)
- (nix-base32-string->bytevector value))
- ((= string-length 64)
- (base16-string->bytevector value))
- (_
- (error "unsupported hash format" value))))))
- (_ #f)))
-
-(define (derivation-source-output-path derivation)
- "Return the output path of the \"src\" attribute of DERIVATION or #f
-if DERIVATION lacks an \"src\" attribute."
- (and=> (derivation-source derivation) source-output-path))
-
-(define* (open-nixpkgs nixpkgs #:optional attribute)
- "Return an input pipe to the XML representation of Nixpkgs. When
-ATTRIBUTE is true, only that attribute is considered."
- (with-fluids ((%default-port-encoding "UTF-8"))
- (let ((cross-system (format #f "{
- config = \"i686-guix-linux-gnu\";
- libc = \"glibc\";
- arch = \"guix\";
- withTLS = true;
- float = \"hard\";
- openssl.system = \"linux-generic32\";
- platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug;
-}" nixpkgs)))
- (apply open-pipe* OPEN_READ
- "nix-instantiate" "--strict" "--eval-only" "--xml"
-
- ;; Pass a dummy `crossSystem' argument so that `buildInputs' and
- ;; `nativeBuildInputs' are not coalesced.
- ;; XXX: This is hacky and has other problems.
- ;"--arg" "crossSystem" cross-system
-
- `(,@(if attribute
- `("-A" ,attribute)
- '())
- ,nixpkgs)))))
-
-(define (pipe-failed? pipe)
- "Close pipe and return its status if it failed."
- (let ((status (close-pipe pipe)))
- (if (or (status:term-sig status)
- (not (= (status:exit-val status) 0)))
- status
- #f)))
-
-(define (find-attribute-by-name name attributes)
- "Return attribute NAME in ATTRIBUTES, an attribute set or list of SNix
-attributes, or #f if NAME cannot be found."
- (find (lambda (a)
- (match a
- (('attribute _ (? (cut string=? <> name)) _)
- a)
- (_ #f)))
- (match attributes
- (('attribute-set (attributes ...))
- attributes)
- (_
- attributes))))
-
-(define (license-variable license)
- "Return the name of the (guix licenses) variable for LICENSE."
- (match license
- ("GPLv2+" 'gpl2+)
- ("GPLv3+" 'gpl3+)
- ("LGPLv2+" 'lgpl2.1+)
- ("LGPLv2.1+" 'lgpl2.1+)
- ("LGPLv3+" 'lgpl3+)
- (('attribute-set _ ...)
- ;; At some point in 2013, Nixpkgs switched to attribute sets to represent
- ;; licenses. These are listed in lib/licenses.nix.
- (match (and=> (find-attribute-by-name "shortName" license)
- attribute-value)
- ("agpl3Plus" 'agpl3+)
- ("gpl2Plus" 'gpl2+)
- ("gpl3Plus" 'gpl3+)
- ("lgpl2Plus" 'lgpl2.0+)
- ("lgpl21Plus" 'lgpl2.1+)
- ("lgpl3Plus" 'lgpl3+)
- ((? string? x) x)
- (_ license)))
- (_ license)))
-
-(define (package-source-output-path package)
- "Return the output path of the \"src\" derivation of PACKAGE."
- (derivation-source-output-path (attribute-value package)))
-
-
-;;;
-;;; Conversion of "Nix expressions" to "Guix expressions".
-;;;
-
-(define (snix-derivation->guix-package derivation)
- "Return the `package' s-expression corresponding to SNix DERIVATION, a
-Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source
-location of DERIVATION."
- (match derivation
- (('derivation _ _ (attributes ...))
- (let*-values (((full-name loc)
- (match (find-attribute-by-name "name" attributes)
- (('attribute loc _ value)
- (values value loc))
- (_
- (values #f #f))))
- ((name version)
- (package-name->name+version full-name)))
- (define (convert-inputs type)
- ;; Convert the derivation's input from a list of SNix derivations to
- ;; a list of name/variable pairs.
- (match (and=> (find-attribute-by-name type attributes)
- attribute-value)
- (#f
- '())
- ((inputs ...)
- ;; Inputs can be either derivations or the null value.
- (filter-map (match-lambda
- (('derivation _ _ (attributes ...))
- (let* ((full-name
- (attribute-value
- (find-attribute-by-name "name" attributes)))
- (name (package-name->name+version full-name)))
- (list name
- (list 'unquote (string->symbol name)))))
- ('null #f))
- inputs))))
-
- (define (maybe-inputs guix-name inputs)
- (match inputs
- (()
- '())
- ((inputs ...)
- (list (list guix-name
- (list 'quasiquote inputs))))))
-
- (define (pretty-uri uri version)
- (if version
- (match (factorize-uri uri version)
- ((items ...)
- `(string-append ,@items))
- (x x))
- uri))
-
- (let* ((source (find-attribute-by-name "src" attributes))
- (urls (source-urls source))
- (sha256 (source-sha256 source))
- (meta (and=> (find-attribute-by-name "meta" attributes)
- attribute-value)))
- (values
- `(package
- (name ,name)
- (version ,version)
- (source (origin
- (method url-fetch)
- (uri ,(pretty-uri (car urls) version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string sha256)))))
- (build-system gnu-build-system)
-
- ;; When doing a native Nixpkgs build, `buildInputs' is empty and
- ;; everything is in `nativeBuildInputs'. So we can't distinguish
- ;; between both, here.
- ;;
- ;; Note that `nativeBuildInputs' was renamed from
- ;; `buildNativeInputs' in Nixpkgs sometime around March 2013.
- ,@(maybe-inputs 'inputs
- (convert-inputs "nativeBuildInputs"))
- ,@(maybe-inputs 'propagated-inputs
- (convert-inputs "propagatedNativeBuildInputs"))
-
- (home-page ,(and=> (find-attribute-by-name "homepage" meta)
- attribute-value))
- (synopsis
- ;; For GNU packages, prefer the official synopsis.
- ,(or (false-if-exception
- (and=> (find (lambda (gnu-package)
- (equal? (gnu-package-name gnu-package)
- name))
- (official-gnu-packages))
- gnu-package-doc-summary))
- (and=> (find-attribute-by-name "description" meta)
- attribute-value)))
- (description
- ;; Likewise, prefer the official description of GNU packages.
- ,(or (false-if-exception
- (and=> (find (lambda (gnu-package)
- (equal? (gnu-package-name gnu-package)
- name))
- (official-gnu-packages))
- gnu-package-doc-description))
- (and=> (find-attribute-by-name "longDescription" meta)
- attribute-value)))
- (license ,(and=> (find-attribute-by-name "license" meta)
- (compose license-variable attribute-value))))
- loc))))))
-
-(define (nixpkgs->guix-package nixpkgs attribute)
- "Evaluate ATTRIBUTE in NIXPKGS, the file name of a Nixpkgs checkout,
-and return the `package' s-expression corresponding to that package."
- (let ((port (open-nixpkgs nixpkgs attribute)))
- (match (xml->snix port)
- (('snix loc (and drv ('derivation _ ...)))
- (and (not (pipe-failed? port))
- (snix-derivation->guix-package drv)))
- (_
- (not (pipe-failed? port))))))
-
-;;; snix.scm ends here
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index bbd903a2cd..731e69651e 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,10 +22,12 @@
(define-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 control)
#: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)
@@ -141,11 +144,23 @@ PACKAGE or #f if the package is not included in the Stackage LTS release."
(version version)
(urls (list url))))))))))
+(define (stackage-package? package)
+ "Whether PACKAGE is available on the default Stackage LTS release."
+ (and (hackage-package? package)
+ (let ((packages (lts-info-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)))))
+
(define %stackage-updater
(upstream-updater
(name 'stackage)
(description "Updater for Stackage LTS packages")
- (pred hackage-package?)
+ (pred stackage-package?)
(latest latest-lts-release)))
;;; stackage.scm ends here
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index d817318a91..a180742ca3 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -133,8 +134,14 @@ of the string VERSION is replaced by the symbol 'version."
;; Please update guix/licenses.scm when modifying
;; this list to avoid mismatches.
(match str
+ ;; "GPL-N+" has been deprecated in favour of "GPL-N-or-later".
+ ;; "GPL-N" has been deprecated in favour of "GPL-N-only"
+ ;; or "GPL-N-or-later" as appropriate. Likewise for LGPL
+ ;; and AGPL
("AGPL-1.0" 'license:agpl1)
("AGPL-3.0" 'license:agpl3)
+ ("AGPL-3.0-only" 'license:agpl3)
+ ("AGPL-3.0-or-later" 'license:agpl3+)
("Apache-1.1" 'license:asl1.1)
("Apache-2.0" 'license:asl2.0)
("BSL-1.0" 'license:boost1.0)
@@ -161,11 +168,17 @@ of the string VERSION is replaced by the symbol 'version."
("GFDL-1.3" 'license:fdl1.3+)
("Giftware" 'license:giftware)
("GPL-1.0" 'license:gpl1)
+ ("GPL-1.0-only" 'license:gpl1)
("GPL-1.0+" 'license:gpl1+)
+ ("GPL-1.0-or-later" 'license:gpl1+)
("GPL-2.0" 'license:gpl2)
+ ("GPL-2.0-only" 'license:gpl2)
("GPL-2.0+" 'license:gpl2+)
+ ("GPL-2.0-or-later" 'license:gpl2+)
("GPL-3.0" 'license:gpl3)
+ ("GPL-3.0-only" 'license:gpl3)
("GPL-3.0+" 'license:gpl3+)
+ ("GPL-3.0-or-later" 'license:gpl3+)
("ISC" 'license:isc)
("IJG" 'license:ijg)
("Imlib2" 'license:imlib2)
@@ -173,11 +186,17 @@ of the string VERSION is replaced by the symbol 'version."
("IPL-1.0" 'license:ibmpl1.0)
("LAL-1.3" 'license:lal1.3)
("LGPL-2.0" 'license:lgpl2.0)
+ ("LGPL-2.0-only" 'license:lgpl2.0)
("LGPL-2.0+" 'license:lgpl2.0+)
+ ("LGPL-2.0-or-later" 'license:lgpl2.0+)
("LGPL-2.1" 'license:lgpl2.1)
+ ("LGPL-2.1-only" 'license:lgpl2.1)
("LGPL-2.1+" 'license:lgpl2.1+)
+ ("LGPL-2.1-or-later" 'license:lgpl2.1+)
("LGPL-3.0" 'license:lgpl3)
+ ("LGPL-3.0-only" 'license:lgpl3)
("LGPL-3.0+" 'license:lgpl3+)
+ ("LGPL-3.0-or-later" 'license:lgpl3+)
("MPL-1.0" 'license:mpl1.0)
("MPL-1.1" 'license:mpl1.1)
("MPL-2.0" 'license:mpl2.0)
@@ -471,15 +490,16 @@ to obtain the Guix package name corresponding to the upstream name."
(name (list name #f))) dependencies)))
(make-node name version package normalized-deps)))
- (map node-package
- (topological-sort (list (lookup-node package-name version))
- (lambda (node)
- (map (lambda (name-version)
- (apply lookup-node name-version))
- (remove (lambda (name-version)
- (apply exists? name-version))
- (node-dependencies node))))
- (lambda (node)
- (string-append
- (node-name node)
- (or (node-version node) ""))))))
+ (filter-map
+ node-package
+ (topological-sort (list (lookup-node package-name version))
+ (lambda (node)
+ (map (lambda (name-version)
+ (apply lookup-node name-version))
+ (remove (lambda (name-version)
+ (apply exists? name-version))
+ (node-dependencies node))))
+ (lambda (node)
+ (string-append
+ (node-name node)
+ (or (node-version node) ""))))))
generated by cgit v1.2.3 (git 2.50.1) at 2025-09-23 19:48:40 +0000