From 613a9c7cb3419d2301cd4748cd0db90e880278c5 Mon Sep 17 00:00:00 2001 From: Brice Waegeneire Date: Wed, 4 Aug 2021 16:59:40 +0200 Subject: import: gem: Fix typo. * guix/scripts/import/gem.scm (%options): Fix typo. --- guix/scripts/import/gem.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index 65d2bf10b4..328d20b946 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021 Brice Waegeneire ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,7 +61,7 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix import pypi"))) + (show-version-and-exit "guix import gem"))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) -- cgit v1.2.3 From 467e874a86dc3dd83fe10e5610823c011de6565a Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 10 Aug 2021 17:07:20 +0200 Subject: guix: Add ContentDB importer. * guix/import/contentdb.scm: New file. * guix/scripts/import/contentdb.scm: New file. * tests/contentdb.scm: New file. * Makefile.am (MODULES, SCM_TESTS): Register them. * po/guix/POTFILES.in: Likewise. * doc/guix.texi (Invoking guix import): Document it. Signed-off-by: Leo Prikler --- Makefile.am | 3 + doc/guix.texi | 32 +++ guix/import/minetest.scm | 456 +++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 3 +- guix/scripts/import/minetest.scm | 117 ++++++++++ po/guix/POTFILES.in | 1 + tests/minetest.scm | 355 ++++++++++++++++++++++++++++++ 7 files changed, 966 insertions(+), 1 deletion(-) create mode 100644 guix/import/minetest.scm create mode 100644 guix/scripts/import/minetest.scm create mode 100644 tests/minetest.scm (limited to 'guix/scripts') diff --git a/Makefile.am b/Makefile.am index 344b7423c5..327d3f9961 100644 --- a/Makefile.am +++ b/Makefile.am @@ -262,6 +262,7 @@ MODULES = \ guix/import/json.scm \ guix/import/kde.scm \ guix/import/launchpad.scm \ + guix/import/minetest.scm \ guix/import/opam.scm \ guix/import/print.scm \ guix/import/pypi.scm \ @@ -304,6 +305,7 @@ MODULES = \ guix/scripts/import/go.scm \ guix/scripts/import/hackage.scm \ guix/scripts/import/json.scm \ + guix/scripts/import/minetest.scm \ guix/scripts/import/opam.scm \ guix/scripts/import/pypi.scm \ guix/scripts/import/stackage.scm \ @@ -470,6 +472,7 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ + tests/minetest.scm \ tests/modules.scm \ tests/monads.scm \ tests/nar.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index d6197d3743..241a1824ec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11314,6 +11314,38 @@ and generate package expressions for all those packages that are not yet in Guix. @end table +@item contentdb +@cindex minetest +@cindex ContentDB +Import metadata from @uref{https://content.minetest.net, ContentDB}. +Information is taken from the JSON-formatted metadata provided through +@uref{https://content.minetest.net/help/api/, ContentDB's API} and +includes most relevant information, including dependencies. There are +some caveats, however. The license information is often incomplete. +The commit hash is sometimes missing. The descriptions are in the +Markdown format, but Guix uses Texinfo instead. Texture packs and +subgames are unsupported. + +The command below imports metadata for the Mesecons mod by Jeija: + +@example +guix import minetest Jeija/mesecons +@end example + +The author name can also be left out: + +@example +guix import minetest mesecons +@end example + +@table @code +@item --recursive +@itemx -r +Traverse the dependency graph of the given upstream package recursively +and generate package expressions for all those packages that are not yet +in Guix. +@end table + @item cpan @cindex CPAN Import metadata from @uref{https://www.metacpan.org/, MetaCPAN}. diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm new file mode 100644 index 0000000000..e1f8487b75 --- /dev/null +++ b/guix/import/minetest.scm @@ -0,0 +1,456 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxime Devos +;;; +;;; 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 . + +(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 +;; . + +(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 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 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 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 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 object, return the corresponding AUTHOR/NAME string." + (%construct-full-name (package-author package) (package-name package))) + +(define (package-keys-full-name package) + "Given a 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 ambigious, 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 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 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 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 thes search results to +respectively mods, games and texture packs. Limit to at most LIMIT +results. The return value is a list of 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))) + +;; 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)) + (filter-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-title release) ; version + (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/scripts/import.scm b/guix/scripts/import.scm index f53d1ac1f4..b369a362d0 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -77,7 +77,8 @@ rather than \\n." ;;; (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" - "gem" "go" "cran" "crate" "texlive" "json" "opam")) + "gem" "go" "cran" "crate" "texlive" "json" "opam" + "minetest")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/minetest.scm b/guix/scripts/import/minetest.scm new file mode 100644 index 0000000000..5f204d90fc --- /dev/null +++ b/guix/scripts/import/minetest.scm @@ -0,0 +1,117 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Maxime Devos +;;; +;;; 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 . + +(define-module (guix scripts import minetest) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import minetest) + #:use-module (guix import utils) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-minetest)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + `((sort . ,%default-sort-key))) + +(define (show-help) + (display (G_ "Usage: guix import minetest AUTHOR/NAME +Import and convert the Minetest mod NAME by AUTHOR from ContentDB.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (display (G_ " + --sort=KEY when choosing between multiple implementations, + choose the one with the highest value for KEY + (one of \"score\" (standard) or \"downloads\")")) + (newline) + (show-bug-report-information)) + +(define (verify-sort-order sort) + "Verify SORT can be used to sort mods by." + (unless (member sort '("score" "downloads" "reviews")) + (leave (G_ "~a: not a valid key to sort by~%") sort)) + sort) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import minetest"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + (option '("sort") #t #f + (lambda (opt name arg result) + (alist-cons 'sort (verify-sort-order arg) result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-minetest . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((name) + (with-error-handling + (let* ((sort (assoc-ref opts 'sort)) + (author/name (elaborate-contentdb-name name #:sort sort))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (filter-map package->definition + (minetest-recursive-import author/name #:sort sort)) + ;; Single import + (minetest->guix-package author/name #:sort sort))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 14324b25de..1eee82be53 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -60,6 +60,7 @@ guix/scripts/git.scm guix/scripts/git/authenticate.scm guix/scripts/hash.scm guix/scripts/import.scm +guix/scripts/import/contentdb.scm guix/scripts/import/cran.scm guix/scripts/import/elpa.scm guix/scripts/pull.scm diff --git a/tests/minetest.scm b/tests/minetest.scm new file mode 100644 index 0000000000..6ae476fe5f --- /dev/null +++ b/tests/minetest.scm @@ -0,0 +1,355 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxime Devos +;;; +;;; 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 . + +(define-module (test-minetest) + #:use-module (guix memoization) + #:use-module (guix import minetest) + #:use-module (guix import utils) + #:use-module (guix tests) + #:use-module (json) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64)) + + +;; Some procedures for populating a ‘fake’ ContentDB server. + +(define* (make-package-sexp #:key + (guix-name "minetest-foo") + (home-page "https://example.org/foo") + (repo "https://example.org/foo.git") + (synopsis "synopsis") + (guix-description "description") + (guix-license + '(list license:cc-by-sa4.0 license:lgpl3+)) + (inputs '()) + (upstream-name "Author/foo") + #:allow-other-keys) + `(package + (name ,guix-name) + ;; This is not a proper version number but ContentDB does not include + ;; version numbers. + (version "2021-07-25") + (source + (origin + (method git-fetch) + (uri (git-reference + (url ,(and (not (eq? repo 'null)) repo)) + (commit #f))) + (sha256 + (base32 #f)) + (file-name (git-file-name name version)))) + (build-system minetest-mod-build-system) + ,@(maybe-propagated-inputs inputs) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,guix-description) + (license ,guix-license) + (properties + ,(list 'quasiquote + `((upstream-name . ,upstream-name)))))) + +(define* (make-package-json #:key + (author "Author") + (name "foo") + (media-license "CC-BY-SA-4.0") + (license "LGPL-3.0-or-later") + (short-description "synopsis") + (long-description "description") + (repo "https://example.org/foo.git") + (website "https://example.org/foo") + (forums 321) + (score 987.654) + (downloads 123) + (type "mod") + #:allow-other-keys) + `(("author" . ,author) + ("content_warnings" . #()) + ("created_at" . "2018-05-23T19:58:07.422108") + ("downloads" . ,downloads) + ("forums" . ,forums) + ("issue_tracker" . "https://example.org/foo/issues") + ("license" . ,license) + ("long_description" . ,long-description) + ("maintainers" . #("maintainer")) + ("media_license" . ,media-license) + ("name" . ,name) + ("provides" . #("stuff")) + ("release" . 456) + ("repo" . ,repo) + ("score" . ,score) + ("screenshots" . #()) + ("short_description" . ,short-description) + ("state" . "APPROVED") + ("tags" . #("some" "tags")) + ("thumbnail" . null) + ("title" . "The name") + ("type" . ,type) + ("url" . ,(string-append "https://content.minetest.net/packages/" + author "/" name "/download/")) + ("website" . ,website))) + +(define* (make-releases-json #:key (commit #f) (title "") #:allow-other-keys) + `#((("commit" . ,commit) + ("downloads" . 469) + ("id" . 8614) + ("max_minetest_version" . null) + ("min_minetest_version" . null) + ("release_date" . "2021-07-25T01:10:23.207584") + ("title" . "2021-07-25")))) + +(define* (make-dependencies-json #:key (author "Author") + (name "foo") + (requirements '(("default" #f ()))) + #:allow-other-keys) + `((,(string-append author "/" name) + . ,(list->vector + (map (match-lambda + ((symbolic-name optional? implementations) + `(("is_optional" . ,optional?) + ("name" . ,symbolic-name) + ("packages" . ,(list->vector implementations))))) + requirements))) + ("something/else" . #()))) + +(define* (make-packages-keys-json #:key (author "Author") + (name "Name") + (type "mod")) + `(("author" . ,author) + ("name" . ,name) + ("type" . ,type))) + +(define (call-with-packages thunk . argument-lists) + ;; Don't reuse results from previous tests. + (invalidate-memoization! contentdb-fetch) + (invalidate-memoization! minetest->guix-package) + (define (scm->json-port scm) + (open-input-string (scm->json-string scm))) + (define (handle-package url requested-author requested-name . rest) + (define relevant-argument-list + (any (lambda (argument-list) + (apply (lambda* (#:key (author "Author") (name "foo") + #:allow-other-keys) + (and (equal? requested-author author) + (equal? requested-name name) + argument-list)) + argument-list)) + argument-lists)) + (when (not relevant-argument-list) + (error "the package ~a/~a should be irrelevant, but ~a is fetched" + requested-author requested-name url)) + (scm->json-port + (apply (match rest + (("") make-package-json) + (("dependencies" "") make-dependencies-json) + (("releases" "") make-releases-json) + (_ (error "TODO ~a" rest))) + relevant-argument-list))) + (define (handle-mod-search sort) + ;; Produce search results, sorted by SORT in descending order. + (define arguments->key + (match sort + ("score" (lambda* (#:key (score 987.654) #:allow-other-keys) + score)) + ("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys) + downloads)))) + (define argument-list->key (cut apply arguments->key <>)) + (define (greater x y) + (> (argument-list->key x) (argument-list->key y))) + (define sorted-argument-lists (sort-list argument-lists greater)) + (define* (arguments->json #:key (author "Author") (name "Foo") (type "mod") + #:allow-other-keys) + (and (string=? type "mod") + `(("author" . ,author) + ("name" . ,name) + ("type" . ,type)))) + (define argument-list->json (cut apply arguments->json <>)) + (scm->json-port + (list->vector (filter-map argument-list->json sorted-argument-lists)))) + (mock ((guix http-client) http-fetch + (lambda* (url #:key headers) + (unless (string-prefix? "mock://api/packages/" url) + (error "the URL ~a should not be used" url)) + (define resource + (substring url (string-length "mock://api/packages/"))) + (define components (string-split resource #\/)) + (match components + ((author name . rest) + (apply handle-package url author name rest)) + (((? (cut string-prefix? "?type=mod&q=" <>) query)) + (handle-mod-search + (cond ((string-contains query "sort=score") "score") + ((string-contains query "sort=downloads") "downloads") + (#t (error "search query ~a has unknown sort key" + query))))) + (_ + (error "the URL ~a should have an author and name component" + url))))) + (parameterize ((%contentdb-api "mock://api/")) + (thunk)))) + +(define* (minetest->guix-package* #:key (author "Author") (name "foo") + (sort %default-sort-key) + #:allow-other-keys) + (minetest->guix-package (string-append author "/" name) #:sort sort)) + +(define (imported-package-sexp* primary-arguments . secondary-arguments) + "Ask the importer to import a package specified by PRIMARY-ARGUMENTS, +during a dynamic where that package and the packages specified by +SECONDARY-ARGUMENTS are available on ContentDB." + (apply call-with-packages + (lambda () + ;; The memoization cache is reset by call-with-packages + (apply minetest->guix-package* primary-arguments)) + primary-arguments + secondary-arguments)) + +(define (imported-package-sexp . extra-arguments) + "Ask the importer to import a package specified by EXTRA-ARGUMENTS, +during a dynamic extent where that package is available on ContentDB." + (imported-package-sexp* extra-arguments)) + +(define-syntax-rule (test-package test-case . extra-arguments) + (test-equal test-case + (make-package-sexp . extra-arguments) + (imported-package-sexp . extra-arguments))) + +(define-syntax-rule (test-package* test-case primary-arguments extra-arguments + ...) + (test-equal test-case + (apply make-package-sexp primary-arguments) + (imported-package-sexp* primary-arguments extra-arguments ...))) + +(test-begin "minetest") + + +;; Package names +(test-package "minetest->guix-package") +(test-package "minetest->guix-package, _ → - in package name" + #:name "foo_bar" + #:guix-name "minetest-foo-bar" + #:upstream-name "Author/foo_bar") + +(test-equal "elaborate names, unambigious" + "Jeija/mesecons" + (call-with-packages + (cut elaborate-contentdb-name "mesecons") + '(#:name "mesecons" #:author "Jeija") + '(#:name "something" #:author "else"))) + +(test-equal "elaborate name, ambigious (highest score)" + "Jeija/mesecons" + (call-with-packages + ;; #:sort "score" is the default + (cut elaborate-contentdb-name "mesecons") + '(#:name "mesecons" #:author "Jeijc" #:score 777) + '(#:name "mesecons" #:author "Jeijb" #:score 888) + '(#:name "mesecons" #:author "Jeija" #:score 999))) + + +(test-equal "elaborate name, ambigious (most downloads)" + "Jeija/mesecons" + (call-with-packages + (cut elaborate-contentdb-name "mesecons" #:sort "downloads") + '(#:name "mesecons" #:author "Jeijc" #:downloads 777) + '(#:name "mesecons" #:author "Jeijb" #:downloads 888) + '(#:name "mesecons" #:author "Jeija" #:downloads 999))) + + +;; Determining the home page +(test-package "minetest->guix-package, website is used as home page" + #:home-page "web://site" + #:website "web://site") +(test-package "minetest->guix-package, if absent, the forum is used" + #:home-page '(minetest-topic 628) + #:forums 628 + #:website 'null) +(test-package "minetest->guix-package, if absent, the git repo is used" + #:home-page "https://github.com/minetest-mods/mesecons" + #:forums 'null + #:website 'null + #:repo "https://github.com/minetest-mods/mesecons") +(test-package "minetest->guix-package, all home page information absent" + #:home-page #f + #:forums 'null + #:website 'null + #:repo 'null) + + + +;; Dependencies +(test-package* "minetest->guix-package, unambigious dependency" + (list #:requirements '(("mesecons" #f + ("Jeija/mesecons" + "some-modpack/containing-mese"))) + #:inputs '("minetest-mesecons")) + (list #:author "Jeija" #:name "mesecons") + (list #:author "some-modpack" #:name "containing-mese" #:type "modpack")) + +(test-package* "minetest->guix-package, ambigious dependency (highest score)" + (list #:name "frobnicate" + #:guix-name "minetest-frobnicate" + #:upstream-name "Author/frobnicate" + #:requirements '(("frob" #f + ("Author/foo" "Author/bar"))) + ;; #:sort "score" is the default + #:inputs '("minetest-bar")) + (list #:author "Author" #:name "foo" #:score 0) + (list #:author "Author" #:name "bar" #:score 9999)) + +(test-package* "minetest->guix-package, ambigious dependency (most downloads)" + (list #:name "frobnicate" + #:guix-name "minetest-frobnicate" + #:upstream-name "Author/frobnicate" + #:requirements '(("frob" #f + ("Author/foo" "Author/bar"))) + #:inputs '("minetest-bar") + #:sort "downloads") + (list #:author "Author" #:name "foo" #:downloads 0) + (list #:author "Author" #:name "bar" #:downloads 9999)) + +(test-package "minetest->guix-package, optional dependency" + #:requirements '(("mesecons" #t + ("Jeija/mesecons" + "some-modpack/containing-mese"))) + #:inputs '()) + + +;; License +(test-package "minetest->guix-package, identical licenses" + #:guix-license 'license:lgpl3+ + #:license "LGPL-3.0-or-later" + #:media-license "LGPL-3.0-or-later") + +;; Sorting +(let* ((make-package + (lambda arguments + (json->package (apply make-package-json arguments)))) + (x (make-package #:score 0)) + (y (make-package #:score 1)) + (z (make-package #:score 2))) + (test-equal "sort-packages, already sorted" + (list z y x) + (sort-packages (list z y x))) + (test-equal "sort-packages, reverse" + (list z y x) + (sort-packages (list x y z)))) + +(test-end "minetest") -- cgit v1.2.3 From fc29c80b9635ff490bcc768c774442043cb1e231 Mon Sep 17 00:00:00 2001 From: Alice BRENON Date: Sat, 7 Aug 2021 19:50:10 +0200 Subject: guix: opam: More flexibility in the importer. * guix/scripts/import/opam.scm: Pass all instances of --repo as a list to the importer. * guix/import/opam.scm (opam-fetch): Stop expecting "expanded" repositories and call get-opam-repository instead to keep values "symbolic" as long as possible and factorize. (get-opam-repository): Use the same repository source as CLI opam does (i.e. HTTP-served index.tar.gz instead of git repositories). (find-latest-version): Be more flexible on the repositories structure instead of expecting packages/PACKAGE-NAME/PACKAGE-NAME.VERSION/. * tests/opam.scm: Update the call to opam->guix-package since repo is now expected to be a list and remove the mocked get-opam-repository deprecated by the support for local folders by the actual implementation. * doc/guix.texi: Document the new semantics and valid arguments for the --repo option. Signed-off-by: Julien Lepiller --- doc/guix.texi | 29 ++++++-- guix/import/opam.scm | 158 ++++++++++++++++++++++++++----------------- guix/scripts/import/opam.scm | 8 ++- tests/opam.scm | 68 +++++++++---------- 4 files changed, 159 insertions(+), 104 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 949d6d4092..5155e67481 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -95,6 +95,7 @@ Copyright @copyright{} 2021 Raghav Gururajan@* Copyright @copyright{} 2021 Domagoj Stolfa@* Copyright @copyright{} 2021 Hui Lu@* Copyright @copyright{} 2021 pukkamustard@* +Copyright @copyright{} 2021 Alice Brenon@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -11659,14 +11660,30 @@ Traverse the dependency graph of the given upstream package recursively and generate package expressions for all those packages that are not yet in Guix. @item --repo -Select the given repository (a repository name). Possible values include: +By default, packages are searched in the official OPAM repository. This +option, which can be used more than once, lets you add other repositories +which will be searched for packages. It accepts as valid arguments: + @itemize -@item @code{opam}, the default opam repository, -@item @code{coq} or @code{coq-released}, the stable repository for coq packages, -@item @code{coq-core-dev}, the repository that contains development versions of coq, -@item @code{coq-extra-dev}, the repository that contains development versions - of coq packages. +@item the name of a known repository - can be one of @code{opam}, + @code{coq} (equivalent to @code{coq-released}), + @code{coq-core-dev}, @code{coq-extra-dev} or @code{grew}. +@item the URL of a repository as expected by the @code{opam repository + add} command (for instance, the URL equivalent of the above + @code{opam} name would be @uref{https://opam.ocaml.org}). +@item the path to a local copy of a repository (a directory containing a + @file{packages/} sub-directory). @end itemize + +Repositories are assumed to be passed to this option by order of +preference. The additional repositories will not replace the default +@code{opam} repository, which is always kept as a fallback. + +Also, please note that versions are not compared accross repositories. +The first repository (from left to right) that has at least one version +of a given package will prevail over any others, and the version +imported will be the latest one found @emph{in this repository only}. + @end table @item go diff --git a/guix/import/opam.scm b/guix/import/opam.scm index a35b01d277..fe13d29f03 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Julien Lepiller ;;; Copyright © 2020 Martin Becze ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Alice Brenon ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,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 @@ -121,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 @@ -266,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))) - -(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->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 + (lambda (dependency) + (list dependency (list 'unquote (string->symbol dependency)))) + (ocaml-names->guix-names lst))) + +(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 '()) 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")) @@ -312,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) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index 64164e7cc4..834ac34cb0 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller ;;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021 Alice Brenon ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,7 +47,8 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (display (G_ " -r, --recursive import packages recursively")) (display (G_ " - --repo import packages from this opam repository")) + --repo import packages from this opam repository (name, URL or local path) + can be used more than once")) (display (G_ " -V, --version display version information and exit")) (newline) @@ -81,7 +83,9 @@ Import and convert the opam package for PACKAGE-NAME.\n")) #:build-options? #f)) (let* ((opts (parse-options)) - (repo (and=> (assoc-ref opts 'repo) string->symbol)) + (repo (filter-map (match-lambda + (('repo . name) name) + (_ #f)) opts)) (args (filter-map (match-lambda (('argument . value) value) diff --git a/tests/opam.scm b/tests/opam.scm index f1e3b70cb0..1536b74339 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -82,41 +82,39 @@ url { (set! test-source-hash (call-with-input-file file-name port-sha256)))) (_ (error "Unexpected URL: " url))))) - (mock ((guix import opam) get-opam-repository - (const test-repo)) - (let ((my-package (string-append test-repo - "/packages/foo/foo.1.0.0"))) - (mkdir-p my-package) - (with-output-to-file (string-append my-package "/opam") - (lambda _ - (format #t "~a" test-opam-file)))) - (match (opam->guix-package "foo" #:repo test-repo) - (('package - ('name "ocaml-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri "https://example.org/foo-1.0.0.tar.gz") - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'ocaml-build-system) - ('propagated-inputs - ('quasiquote - (("ocaml-zarith" ('unquote 'ocaml-zarith))))) - ('native-inputs - ('quasiquote - (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) - ("ocamlbuild" ('unquote 'ocamlbuild))))) - ('home-page "https://example.org/") - ('synopsis "Some example package") - ('description "This package is just an example.") - ('license 'license:bsd-3)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f)))))) + (let ((my-package (string-append test-repo + "/packages/foo/foo.1.0.0"))) + (mkdir-p my-package) + (with-output-to-file (string-append my-package "/opam") + (lambda _ + (format #t "~a" test-opam-file)))) + (match (opam->guix-package "foo" #:repo (list test-repo)) + (('package + ('name "ocaml-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri "https://example.org/foo-1.0.0.tar.gz") + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'ocaml-build-system) + ('propagated-inputs + ('quasiquote + (("ocaml-zarith" ('unquote 'ocaml-zarith))))) + ('native-inputs + ('quasiquote + (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) + ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('home-page "https://example.org/") + ('synopsis "Some example package") + ('description "This package is just an example.") + ('license 'license:bsd-3)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f))))) ;; Test the opam file parser ;; We fold over some test cases. Each case is a pair of the string to parse and the -- cgit v1.2.3 From 2ca982ff41270288913ad6b7d5d9e1cad87b06d9 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 6 Aug 2021 16:33:02 -0400 Subject: gnu: bootloader: Support multiple targets. Fixes . * gnu/bootloader.scm (): New 'targets' field. (%bootloader-configuration-target): New procedure. (bootloader-configuration-target): Add deprecation warning. (bootloader-configuration-targets): New procedure. * guix/scripts/system.scm (install): Access targets via bootloader-configuration-targets. (perform-action)[bootloader-target]: Remove unused argument and update doc. Access targets via bootloader-configuration-targets and fix indentation. (process-action): Access targets via bootloader-configuration-targets. Do not provide the unused BOOTLOADER-TARGET argument when applying `perform-action'. * guix/scripts/system/reconfigure.scm (install-bootloader-program): Rename DEVICE argument to DEVICES. Adjust doc and comment. Apply `installer' and `disk-installer' for every DEVICES. (install-bootloader): Access targets via bootloader-configuration-targets and rename variable from DEVICE to DEVICES. * gnu/tests/install.scm: Adjust accordingly. * tests/guix-system.sh: Likewise. * gnu/tests/reconfigure.scm (run-install-bootloader-test): Adjust the DEVICES argument so that it is a list. * doc/guix.texi: Update doc. --- doc/guix.texi | 91 +++++++++++++++++++------------------ gnu/bootloader.scm | 22 ++++++++- gnu/tests/install.scm | 26 +++++------ gnu/tests/reconfigure.scm | 2 +- guix/scripts/system.scm | 20 ++++---- guix/scripts/system/reconfigure.scm | 22 +++++---- tests/guix-system.sh | 6 +-- 7 files changed, 108 insertions(+), 81 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 2b8448c856..6620f882f5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2569,14 +2569,15 @@ in particular: @itemize @item -Make sure the @code{bootloader-configuration} form refers to the target -you want to install GRUB on. It should mention @code{grub-bootloader} if -you are installing GRUB in the legacy way, or @code{grub-efi-bootloader} -for newer UEFI systems. For legacy systems, the @code{target} field -names a device, like @code{/dev/sda}; for UEFI systems it names a path -to a mounted EFI partition, like @code{/boot/efi}; do make sure the path is -currently mounted and a @code{file-system} entry is specified in your -configuration. +Make sure the @code{bootloader-configuration} form refers to the targets +you want to install GRUB on. It should mention @code{grub-bootloader} +if you are installing GRUB in the legacy way, or +@code{grub-efi-bootloader} for newer UEFI systems. For legacy systems, +the @code{targets} field contain the names of the devices, like +@code{(list "/dev/sda")}; for UEFI systems it names the paths to mounted +EFI partitions, like @code{(list "/boot/efi")}; do make sure the paths +are currently mounted and a @code{file-system} entry is specified in +your configuration. @item Be sure that your file system labels match the value of their respective @@ -13543,7 +13544,7 @@ the @code{bootloader} field should contain something along these lines: @lisp (bootloader-configuration (bootloader grub-efi-bootloader) - (target "/boot/efi")) + (targets '("/boot/efi"))) @end lisp @xref{Bootloader Configuration}, for more information on the available @@ -14758,7 +14759,7 @@ configuration would look like: (keyboard-layout (keyboard-layout "tr")) ;for the console (bootloader (bootloader-configuration (bootloader grub-efi-bootloader) - (target "/boot/efi") + (targets '("/boot/efi")) (keyboard-layout keyboard-layout))) ;for GRUB (services (cons (set-xorg-configuration (xorg-configuration ;for Xorg @@ -33188,11 +33189,11 @@ in ``legacy'' BIOS mode. through TFTP@. In combination with an NFS root file system this allows you to build a diskless Guix system. -The installation of the @code{grub-efi-netboot-bootloader} generates the content -of the TFTP root directory at @code{target} -(@pxref{Bootloader Configuration, @code{target}}), to be served by a TFTP server. - You may want to mount your TFTP server directory onto @code{target} to move the -required files to the TFTP server automatically. +The installation of the @code{grub-efi-netboot-bootloader} generates the +content of the TFTP root directory at @code{targets} (@pxref{Bootloader +Configuration, @code{targets}}), to be served by a TFTP server. You may +want to mount your TFTP server directories onto the @code{targets} to +move the required files to the TFTP server automatically. If you plan to use an NFS root file system as well (actually if you mount the store from an NFS share), then the TFTP server needs to serve the file @@ -33203,22 +33204,25 @@ files from the store will be accessed by GRUB through TFTP with their normal store path, for example as @file{tftp://tftp-server/gnu/store/…-initrd/initrd.cpio.gz}. -Two symlinks are created to make this possible. The first symlink is -@code{target}@file{/efi/Guix/boot/grub/grub.cfg} pointing to -@file{../../../boot/grub/grub.cfg}, -where @code{target} may be @file{/boot}. In this case the link is not leaving -the served TFTP root directory, but otherwise it does. The second link is -@code{target}@file{/gnu/store} and points to @file{../gnu/store}. This link -is leaving the served TFTP root directory. - -The assumption behind all this is that you have an NFS server exporting the root -file system for your Guix system, and additionally a TFTP server exporting your -@code{target} directory—usually @file{/boot}—from that same root file system for -your Guix system. In this constellation the symlinks will work. - -For other constellations you will have to program your own bootloader installer, -which then takes care to make necessary files from the store accessible through -TFTP, for example by copying them into the TFTP root directory at @code{target}. +Two symlinks are created to make this possible. For each target in the +@code{targets} field, the first symlink is +@samp{target}@file{/efi/Guix/boot/grub/grub.cfg} pointing to +@file{../../../boot/grub/grub.cfg}, where @samp{target} may be +@file{/boot}. In this case the link is not leaving the served TFTP root +directory, but otherwise it does. The second link is +@samp{target}@file{/gnu/store} and points to @file{../gnu/store}. This +link is leaving the served TFTP root directory. + +The assumption behind all this is that you have an NFS server exporting +the root file system for your Guix system, and additionally a TFTP +server exporting your @code{targets} directories—usually a single +@file{/boot}—from that same root file system for your Guix system. In +this constellation the symlinks will work. + +For other constellations you will have to program your own bootloader +installer, which then takes care to make necessary files from the store +accessible through TFTP, for example by copying them into the TFTP root +directory to your @code{targets}. It is important to note that symlinks pointing outside the TFTP root directory may need to be allowed in the configuration of your TFTP server. Further the @@ -33230,18 +33234,19 @@ NFS servers, you also need a properly configured DHCP server to make the booting over netboot possible. For all this we can currently only recommend you to look for instructions about @acronym{PXE, Preboot eXecution Environment}. -@item @code{target} -This is a string denoting the target onto which to install the +@item @code{targets} +This is a list of strings denoting the targets onto which to install the bootloader. -The interpretation depends on the bootloader in question. For -@code{grub-bootloader}, for example, it should be a device name understood by -the bootloader @command{installer} command, such as @code{/dev/sda} or -@code{(hd0)} (@pxref{Invoking grub-install,,, grub, GNU GRUB Manual}). For -@code{grub-efi-bootloader}, it should be the mount point of the EFI file -system, usually @file{/boot/efi}. For @code{grub-efi-netboot-bootloader}, -@code{target} should be the mount point corresponding to the TFTP root -directory of your TFTP server. +The interpretation of targets depends on the bootloader in question. +For @code{grub-bootloader}, for example, they should be device names +understood by the bootloader @command{installer} command, such as +@code{/dev/sda} or @code{(hd0)} (@pxref{Invoking grub-install,,, grub, +GNU GRUB Manual}). For @code{grub-efi-bootloader}, they should be mount +points of the EFI file system, usually @file{/boot/efi}. For +@code{grub-efi-netboot-bootloader}, @code{targets} should be the mount +points corresponding to TFTP root directories served by your TFTP +server. @item @code{menu-entries} (default: @code{()}) A possibly empty list of @code{menu-entry} objects (see below), denoting @@ -33657,7 +33662,7 @@ files, packages, and so on. It also creates other essential files needed for the system to operate correctly---e.g., the @file{/etc}, @file{/var}, and @file{/run} directories, and the @file{/bin/sh} file. -This command also installs bootloader on the target specified in +This command also installs bootloader on the targets specified in @file{my-os-config}, unless the @option{--no-bootloader} option was passed. @@ -34053,7 +34058,7 @@ evaluates to. As an example, @var{file} might contain a definition like this: (timezone "Etc/UTC") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vda") + (targets '("/dev/vda")) (terminal-outputs '(console)))) (file-systems (cons (file-system (mount-point "/") diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 6d7352ddd2..98807a4810 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -55,7 +55,8 @@ bootloader-configuration bootloader-configuration? bootloader-configuration-bootloader - bootloader-configuration-target + bootloader-configuration-target ;deprecated + bootloader-configuration-targets bootloader-configuration-menu-entries bootloader-configuration-default-entry bootloader-configuration-timeout @@ -183,7 +184,9 @@ record." bootloader-configuration make-bootloader-configuration bootloader-configuration? (bootloader bootloader-configuration-bootloader) ; - (target bootloader-configuration-target ;string + (targets %bootloader-configuration-targets ;list of strings + (default #f)) + (target %bootloader-configuration-target ;deprecated (default #f)) (menu-entries bootloader-configuration-menu-entries ;list of (default '())) @@ -204,6 +207,21 @@ record." (serial-speed bootloader-configuration-serial-speed ;integer | #f (default #f))) +;;; Deprecated. +(define (bootloader-configuration-target config) + (warning (G_ "the 'target' field is deprecated, please use 'targets' \ +instead~%")) + (%bootloader-configuration-target config)) + +(define (bootloader-configuration-targets config) + (or (%bootloader-configuration-targets config) + ;; TODO: Remove after the deprecated 'target' field is removed. + (list (bootloader-configuration-target config)) + ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this + ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f, + ;; hence the default value of '(#f) rather than '(). + (list #f))) + ;;; ;;; Bootloaders. diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 80604361e0..d7fafd210c 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2020 Mathieu Othacehe ;;; Copyright © 2020 Danny Milosavljevic ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,7 +97,7 @@ (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) @@ -135,7 +135,7 @@ (bootloader (bootloader-configuration (bootloader extlinux-bootloader-gpt) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) @@ -418,7 +418,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vda"))) + (targets (list "/dev/vda")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) @@ -549,7 +549,7 @@ partition. In particular, home directories must be correctly created (see (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system (device (file-system-label "root-fs")) @@ -626,7 +626,7 @@ where /gnu lives on a separate partition.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) ;; Add a kernel module for RAID-1 (aka. "mirror"). @@ -842,7 +842,7 @@ build (current-guix) and then store a couple of full system images.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (mapped-devices (list (mapped-device @@ -929,7 +929,7 @@ reboot\n") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (mapped-devices (list (mapped-device (source @@ -1029,7 +1029,7 @@ store a couple of full system images.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) @@ -1103,7 +1103,7 @@ build (current-guix) and then store a couple of full system images.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system @@ -1171,7 +1171,7 @@ RAID-0 (stripe) root partition.") (locale "en_US.UTF-8") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system (device (file-system-label "btrfs-pool")) @@ -1264,7 +1264,7 @@ build (current-guix) and then store a couple of full system images.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) @@ -1337,7 +1337,7 @@ build (current-guix) and then store a couple of full system images.") (bootloader (bootloader-configuration (bootloader grub-bootloader) - (target "/dev/vdb"))) + (targets (list "/dev/vdb")))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system (device (file-system-label "my-root")) diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm index 52beeef447..001b5d185a 100644 --- a/gnu/tests/reconfigure.scm +++ b/gnu/tests/reconfigure.scm @@ -261,7 +261,7 @@ bootloader's configuration file." ;; would attempt to write directly to the virtual disk if the ;; installation script were run. (test - (install-bootloader-program #f #f #f bootcfg bootcfg-file #f "/"))))) + (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/"))))) (define %test-switch-to-system diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 40401d7e03..83bbefd3dc 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -253,7 +253,7 @@ the ownership of '~a' may be incorrect!~%") #:target target) (return (info (G_ "bootloader successfully installed on '~a'~%") - (bootloader-configuration-target bootloader)))))))) + (bootloader-configuration-targets bootloader)))))))) ;;; @@ -768,14 +768,13 @@ and TARGET arguments." skip-safety-checks? install-bootloader? dry-run? derivations-only? - use-substitutes? bootloader-target target + use-substitutes? target full-boot? container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install -bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the -target root directory. +bootloader; TARGET is the target root directory. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? @@ -856,13 +855,13 @@ static checks." #:target (or target "/")) (return (info (G_ "bootloader successfully installed on '~a'~%") - (bootloader-configuration-target bootloader)))) + (bootloader-configuration-targets bootloader)))) (with-shepherd-error-handling - (upgrade-shepherd-services local-eval os) - (return (format #t (G_ "\ + (upgrade-shepherd-services local-eval os) + (return (format #t (G_ "\ To complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, and restart each service that was not automatically restarted.\n"))) - (return (format #t (G_ "\ + (return (format #t (G_ "\ Run 'herd status' to view the list of services on your system.\n")))))) ((init) (newline) @@ -1218,9 +1217,9 @@ resulting from command-line parsing." (target-file (match args ((first second) second) (_ #f))) - (bootloader-target + (bootloader-targets (and bootloader? - (bootloader-configuration-target + (bootloader-configuration-targets (operating-system-bootloader os))))) (define (graph-backend) @@ -1269,7 +1268,6 @@ resulting from command-line parsing." opts) #:install-bootloader? bootloader? #:target target-file - #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) #:target target #:system system))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 49da6ecb16..bf23fb06af 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -207,10 +207,10 @@ services as defined by OS." (define (install-bootloader-program installer disk-installer bootloader-package bootcfg - bootcfg-file device target) + bootcfg-file devices target) "Return an executable store item that, upon being evaluated, will install -BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device, -at TARGET, a mount point, and subsequently run INSTALLER from +BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICES, a list of file system +devices, at TARGET, a mount point, and subsequently run INSTALLER from BOOTLOADER-PACKAGE." (program-file "install-bootloader.scm" @@ -254,11 +254,17 @@ BOOTLOADER-PACKAGE." ;; The bootloader might not support installation on a ;; mounted directory using the BOOTLOADER-INSTALLER ;; procedure. In that case, fallback to installing the - ;; bootloader directly on DEVICE using the + ;; bootloader directly on DEVICES using the ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure. (if #$installer - (#$installer #$bootloader-package #$device #$target) - (#$disk-installer #$bootloader-package 0 #$device))) + (for-each (lambda (device) + (#$installer #$bootloader-package device + #$target)) + '#$devices) + (for-each (lambda (device) + (#$disk-installer #$bootloader-package + 0 device)) + '#$devices))) (lambda args (delete-file new-gc-root) (match args @@ -284,7 +290,7 @@ additional configurations specified by MENU-ENTRIES can be selected." (disk-installer (and run-installer? (bootloader-disk-image-installer bootloader))) (package (bootloader-package bootloader)) - (device (bootloader-configuration-target configuration)) + (devices (bootloader-configuration-targets configuration)) (bootcfg-file (bootloader-configuration-file bootloader))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(install-bootloader-program installer @@ -292,7 +298,7 @@ additional configurations specified by MENU-ENTRIES can be selected." package bootcfg bootcfg-file - device + devices target)))))) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 7e992e7bdb..6aab1f380a 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -115,7 +115,7 @@ cat > "$tmpfile" < ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2021 Simon Tournier +;;; Copyright © 2021 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -358,20 +359,20 @@ References: ~a~%" compression))) compressions) hash size references)) - ;; Do not render a "Deriver" or "System" line if we are rendering - ;; info for a derivation. + ;; Do not render a "Deriver" line if we are rendering info for a + ;; derivation. Also do not render a "System" line that would be + ;; expensive to compute and is currently unused. (info (if (not deriver) base-info (catch 'system-error (lambda () (let ((drv (read-derivation-from-file deriver))) - (format #f "~aSystem: ~a~%Deriver: ~a~%" - base-info (derivation-system drv) - (basename deriver)))) + (format #f "~aDeriver: ~a~%" + base-info (basename deriver)))) (lambda args ;; DERIVER might be missing, but that's fine: ;; it's only used for where it's - ;; optional. 'System' is currently unused. + ;; optional. (if (= ENOENT (system-error-errno args)) base-info (apply throw args)))))) -- cgit v1.2.3 From be13e2be08feb88d868f911d8f55b0451fe15e10 Mon Sep 17 00:00:00 2001 From: zimoun Date: Fri, 6 Aug 2021 11:05:17 -0700 Subject: import: go: Improve error handling. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/go.scm (go-module->guix-package*): Handle errors, remove memoize. (go-module-recursive-import): Remove 'guard', add memoize. * guix/scripts/import/go.scm (guix-import-go): Adjust. * tests/go.scm: Adjust. Signed-off-by: Ludovic Courtès --- guix/import/go.scm | 50 ++++++++++++++++++++++++++++------------------ guix/scripts/import/go.scm | 6 +++--- tests/go.scm | 2 +- 3 files changed, 35 insertions(+), 23 deletions(-) (limited to 'guix/scripts') diff --git a/guix/import/go.scm b/guix/import/go.scm index a4775f973f..4755571209 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2021 Ludovic Courtès ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,6 +64,7 @@ #:use-module (web uri) #:export (go-module->guix-package + go-module->guix-package* go-module-recursive-import)) ;;; Commentary: @@ -646,7 +648,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") @@ -656,23 +679,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 #f '()))) - (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/scripts/import/go.scm b/guix/scripts/import/go.scm index e08a1e427e..f5cfea8683 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -112,10 +112,10 @@ that are not yet in Guix")) (map package->definition* (apply go-module-recursive-import arguments)) ;; Single import. - (let ((sexp (apply go-module->guix-package arguments))) + (let ((sexp (apply go-module->guix-package* arguments))) (unless sexp - (leave (G_ "failed to download meta-data for module '~a'~%") - module-name)) + (leave (G_ "failed to download meta-data for module '~a'.~%") + name)) (package->definition* sexp)))))) (() (leave (G_ "too few arguments~%"))) diff --git a/tests/go.scm b/tests/go.scm index 6749f4585f..9e7223ff7c 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -410,6 +410,6 @@ package.") (nix-base32-string->bytevector "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") #f))) - (go-module->guix-package "github.com/go-check/check"))))))) + (go-module->guix-package* "github.com/go-check/check"))))))) (test-end "go") -- cgit v1.2.3 From e53d8a84c6fbf7641e7d0e6e8658da0bb01fcd71 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Sep 2021 12:00:02 +0200 Subject: publish: Simplify 'narinfo-string'. This is a followup to 222f4661ed11b225f458cbe495a296f233129bec, which was intended to improve performance of 'narinfo-string'. * guix/scripts/publish.scm (narinfo-string): Remove 'catch' and 'read-derivation-from-file' call when rendering "Deriver". --- guix/scripts/publish.scm | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index f67f81acb1..25846b7dc2 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -364,18 +364,8 @@ References: ~a~%" ;; expensive to compute and is currently unused. (info (if (not deriver) base-info - (catch 'system-error - (lambda () - (let ((drv (read-derivation-from-file deriver))) - (format #f "~aDeriver: ~a~%" - base-info (basename deriver)))) - (lambda args - ;; DERIVER might be missing, but that's fine: - ;; it's only used for where it's - ;; optional. - (if (= ENOENT (system-error-errno args)) - base-info - (apply throw args)))))) + (format #f "~aDeriver: ~a~%" + base-info (basename deriver)))) (signature (base64-encode-string (canonical-sexp->string (signed-string info))))) (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) -- cgit v1.2.3 From 9540323458de87b0b8aa421e449a4fe27af7c393 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 1 Aug 2021 16:23:57 +0100 Subject: weather: Don't look for exported package replacements twice. * guix/scripts/weather.scm (all-packages): Delete duplicates, so that exported replacements aren't included twice. --- guix/scripts/weather.scm | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 06312d65a2..60a697d1ac 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -54,16 +54,18 @@ (define (all-packages) "Return the list of public packages we are going to query." - (fold-packages (lambda (package result) - (match (package-replacement package) - ((? package? replacement) - (cons* replacement package result)) - (#f - (cons package result)))) - '() - - ;; Dismiss deprecated packages but keep hidden packages. - #:select? (negate package-superseded))) + (delete-duplicates + (fold-packages (lambda (package result) + (match (package-replacement package) + ((? package? replacement) + (cons* replacement package result)) + (#f + (cons package result)))) + '() + + ;; Dismiss deprecated packages but keep hidden packages. + #:select? (negate package-superseded)) + eq?)) (define (call-with-progress-reporter reporter proc) "This is a variant of 'call-with-progress-reporter' that works with monadic -- cgit v1.2.3