diff options
author | Ludovic Courtès <ludo@gnu.org> | 2021-09-07 11:04:44 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2021-09-07 14:19:08 +0200 |
commit | d9dfbf886ddbb92dfdaa118bb9765e78aad5c53a (patch) | |
tree | 2732020de20a38c09b66a60b0cb36022799f7c2e /guix/import | |
parent | b949f34f31a045eb0fb242b81a223178fb6994d3 (diff) | |
parent | 49922efb11da0f0e9d4f5979d081de5ea8c99d25 (diff) |
Merge branch 'master' into core-updates-frozen
Diffstat (limited to 'guix/import')
-rw-r--r-- | guix/import/egg.scm | 5 | ||||
-rw-r--r-- | guix/import/go.scm | 50 | ||||
-rw-r--r-- | guix/import/minetest.scm | 456 | ||||
-rw-r--r-- | guix/import/opam.scm | 142 | ||||
-rw-r--r-- | guix/import/utils.scm | 44 |
5 files changed, 611 insertions, 86 deletions
diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 86b54ff56f..75b7659944 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -88,7 +88,7 @@ (define (egg-source-url name version) "Return the URL to the source tarball for version VERSION of the CHICKEN egg NAME." - (string-append (%eggs-url) "/" name "/" name "-" version ".tar.gz")) + `(egg-uri ,name version)) (define (egg-name->guix-name name) "Return the package name for CHICKEN egg NAME." @@ -198,7 +198,8 @@ not work." (tarball (if source #f (with-store store - (download-to-store store source-url))))) + (download-to-store + store (egg-uri name version)))))) (define egg-home-page (string-append (%eggs-home-page) "/" name)) diff --git a/guix/import/go.scm b/guix/import/go.scm index 617a0d0e23..4755571209 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -6,6 +6,7 @@ ;;; 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. ;;; @@ -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 '() '()))) - (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/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 <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 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 <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 thes 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))) + +;; 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/import/opam.scm b/guix/import/opam.scm index c42b608ec9..f8402ff5ba 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,21 +24,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 @@ -122,51 +126,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 @@ -267,26 +303,28 @@ 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 string->symbol (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 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 +349,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/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) "")))))) |