summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-09-07 11:04:44 +0200
committerLudovic Courtès <ludo@gnu.org>2021-09-07 14:19:08 +0200
commitd9dfbf886ddbb92dfdaa118bb9765e78aad5c53a (patch)
tree2732020de20a38c09b66a60b0cb36022799f7c2e /guix/import
parentb949f34f31a045eb0fb242b81a223178fb6994d3 (diff)
parent49922efb11da0f0e9d4f5979d081de5ea8c99d25 (diff)
Merge branch 'master' into core-updates-frozen
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/egg.scm5
-rw-r--r--guix/import/go.scm50
-rw-r--r--guix/import/minetest.scm456
-rw-r--r--guix/import/opam.scm142
-rw-r--r--guix/import/utils.scm44
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) ""))))))