summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2021-10-12 16:50:47 +0000
committerMathieu Othacehe <othacehe@gnu.org>2021-10-12 17:46:23 +0000
commita1eca979fb8da842e73c42f4f53be29b169810f2 (patch)
tree681c7283e412bb8a29c2531c4408b49c3e184764 /guix/import
parent48d86a9ec6d8d2e97da2299ea41a03ef4cdaab83 (diff)
parent371aa5777a3805a3886f3feea5f1960fe3fe4219 (diff)
Merge remote-tracking branch 'origin/master' into core-updates-frozen.
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/crate.scm8
-rw-r--r--guix/import/git.scm225
-rw-r--r--guix/import/go.scm13
-rw-r--r--guix/import/hackage.scm11
-rw-r--r--guix/import/minetest.scm73
-rw-r--r--guix/import/pypi.scm20
-rw-r--r--guix/import/stackage.scm111
7 files changed, 398 insertions, 63 deletions
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 287ffd2536..c76d7e9c1a 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;;
@@ -79,7 +79,10 @@
(number crate-version-number "num") ;string
(download-path crate-version-download-path "dl_path") ;string
(readme-path crate-version-readme-path "readme_path") ;string
- (license crate-version-license "license") ;string
+ (license crate-version-license "license" ;string | #f
+ (match-lambda
+ ('null #f)
+ ((? string? str) str)))
(links crate-version-links)) ;alist
;; Crate dependency. Each dependency (each edge in the graph) is annotated as
@@ -198,6 +201,7 @@ and LICENSE."
(description ,(beautify-description description))
(license ,(match license
(() #f)
+ (#f #f)
((license) license)
(_ `(list ,@license)))))))
(close-port port)
diff --git a/guix/import/git.scm b/guix/import/git.scm
new file mode 100644
index 0000000000..1eb219f3fe
--- /dev/null
+++ b/guix/import/git.scm
@@ -0,0 +1,225 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import git)
+ #:use-module (guix build utils)
+ #:use-module (guix diagnostics)
+ #:use-module (guix git)
+ #:use-module (guix git-download)
+ #:use-module (guix i18n)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (%generic-git-updater
+
+ ;; For tests.
+ latest-git-tag-version))
+
+;;; Commentary:
+;;;
+;;; This module provides a generic package updater for packages hosted on Git
+;;; repositories.
+;;;
+;;; It tries to be smart about tag names, but if it is not automatically able
+;;; to parse the tag names correctly, users can set the `release-tag-prefix',
+;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the
+;;; package to make the updater parse the Git tag name correctly.
+;;;
+;;; Possible improvements:
+;;;
+;;; * More robust method for trying to guess the delimiter. Maybe look at the
+;;; previous version/tag combo to determine the delimiter.
+;;;
+;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g.,
+;;; 2021.12.31. Honor a `release-tag-date-scheme?' property?
+;;;
+;;; Code:
+
+;;; Errors & warnings
+
+(define-condition-type &git-no-valid-tags-error &error
+ git-no-valid-tags-error?)
+
+(define (git-no-valid-tags-error)
+ (raise (condition (&message (message "no valid tags found"))
+ (&git-no-valid-tags-error))))
+
+(define-condition-type &git-no-tags-error &error
+ git-no-tags-error?)
+
+(define (git-no-tags-error)
+ (raise (condition (&message (message "no tags were found"))
+ (&git-no-tags-error))))
+
+
+;;; Updater
+
+(define %pre-release-words
+ '("alpha" "beta" "rc" "dev" "test" "pre"))
+
+(define %pre-release-rx
+ (map (lambda (word)
+ (make-regexp (string-append ".+" word) regexp/icase))
+ %pre-release-words))
+
+(define* (version-mapping tags #:key prefix suffix delim pre-releases?)
+ "Given a list of Git TAGS, return an association list where the car is the
+version corresponding to the tag, and the cdr is the name of the tag."
+ (define (guess-delimiter)
+ (let ((total (length tags))
+ (dots (reduce + 0 (map (cut string-count <> #\.) tags)))
+ (dashes (reduce + 0 (map (cut string-count <> #\-) tags)))
+ (underscores (reduce + 0 (map (cut string-count <> #\_) tags))))
+ (cond
+ ((>= dots (* total 0.35)) ".")
+ ((>= dashes (* total 0.8)) "-")
+ ((>= underscores (* total 0.8)) "_")
+ (else ""))))
+
+ (define delim-rx (regexp-quote (or delim (guess-delimiter))))
+ (define suffix-rx (string-append (or suffix "") "$"))
+ (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*")))
+ (define pre-release-rx
+ (if pre-releases?
+ (string-append "(.*(" (string-join %pre-release-words "|") ").*)")
+ ""))
+
+ (define tag-rx
+ (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*"
+ "(" delim-rx "[^[:punct:]" delim-rx "]+)"
+ ;; If there are no delimiters, it could mean that the
+ ;; version just contains one number (e.g., "2"), thus, use
+ ;; "*" instead of "+" to match zero or more numbers.
+ (if (string=? delim-rx "") "*" "+") ")"
+ ;; We don't want the pre-release stuff (e.g., "-alpha") be
+ ;; part of the first group; otherwise, the "-" in "-alpha"
+ ;; might be interpreted as a delimiter, and thus replaced
+ ;; with "."
+ pre-release-rx suffix-rx))
+
+
+
+ (define (get-version tag)
+ (let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
+ (and=> (and tag-match
+ (regexp-substitute/global
+ #f delim-rx (match:substring tag-match 1)
+ ;; If there were no delimiters, don't insert ".".
+ 'pre (if (string=? delim-rx "") "" ".") 'post))
+ (lambda (version)
+ (if pre-releases?
+ (string-append version (match:substring tag-match 3))
+ version)))))
+
+ (define (entry<? a b)
+ (eq? (version-compare (car a) (car b)) '<))
+
+ (stable-sort (filter-map (lambda (tag)
+ (let ((version (get-version tag)))
+ (and version (cons version tag))))
+ tags)
+ entry<?))
+
+(define* (latest-tag url #:key prefix suffix delim pre-releases?)
+ "Return the latest version and corresponding tag available from the Git
+repository at URL."
+ (define (pre-release? tag)
+ (any (cut regexp-exec <> tag)
+ %pre-release-rx))
+
+ (let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
+ (remote-refs url #:tags? #t)))
+ (versions->tags
+ (version-mapping (if pre-releases?
+ tags
+ (filter (negate pre-release?) tags))
+ #:prefix prefix
+ #:suffix suffix
+ #:delim delim
+ #:pre-releases? pre-releases?)))
+ (cond
+ ((null? tags)
+ (git-no-tags-error))
+ ((null? versions->tags)
+ (git-no-valid-tags-error))
+ (else
+ (match (last versions->tags)
+ ((version . tag)
+ (values version tag)))))))
+
+(define (latest-git-tag-version package)
+ "Given a PACKAGE, return the latest version of it, or #f if the latest version
+could not be determined."
+ (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
+ (warning (or (package-field-location package 'source)
+ (package-location package))
+ (G_ "~a for ~a~%")
+ (condition-message c)
+ (package-name package))
+ #f)
+ ((eq? (exception-kind c) 'git-error)
+ (warning (or (package-field-location package 'source)
+ (package-location package))
+ (G_ "failed to fetch Git repository for ~a~%")
+ (package-name package))
+ #f))
+ (let* ((source (package-source package))
+ (url (git-reference-url (origin-uri source)))
+ (property (cute assq-ref (package-properties package) <>)))
+ (latest-tag url
+ #:prefix (property 'release-tag-prefix)
+ #:suffix (property 'release-tag-suffix)
+ #:delim (property 'release-tag-version-delimiter)
+ #:pre-releases? (property 'accept-pre-releases?)))))
+
+(define (git-package? package)
+ "Return true if PACKAGE is hosted on a Git repository."
+ (match (package-source package)
+ ((? origin? origin)
+ (and (eq? (origin-method origin) git-fetch)
+ (git-reference? (origin-uri origin))))
+ (_ #f)))
+
+(define (latest-git-release package)
+ "Return an <upstream-source> for the latest release of PACKAGE."
+ (let* ((name (package-name package))
+ (old-version (package-version package))
+ (url (git-reference-url (origin-uri (package-source package))))
+ (new-version (latest-git-tag-version package)))
+
+ (and new-version
+ (upstream-source
+ (package name)
+ (version new-version)
+ (urls (list url))))))
+
+(define %generic-git-updater
+ (upstream-updater
+ (name 'generic-git)
+ (description "Updater for packages hosted on Git repositories")
+ (pred git-package?)
+ (latest latest-git-release)))
diff --git a/guix/import/go.scm b/guix/import/go.scm
index c6ecdbaffd..26dbc34b63 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -474,13 +474,13 @@ Optionally include a VERSION string to append to the name."
because goproxy servers don't currently provide all the information needed to
build a package."
(define (go-import->module-meta content-text)
- (match (string-split content-text #\space)
+ (match (string-tokenize content-text char-set:graphic)
((root-path vcs repo-url)
(make-module-meta root-path (string->symbol vcs)
(strip-.git-suffix/maybe repo-url)))))
;; <meta name="go-import" content="import-prefix vcs repo-root">
(let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
- (select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
+ (select (sxpath `(// (meta (@ (equal? (name "go-import"))))
// content))))
(match (select (html->sxml meta-data #:strict? #t))
(() #f) ;nothing selected
@@ -612,6 +612,8 @@ hint: use one of the following available versions ~a\n"
(dependencies (if pin-versions?
dependencies+versions
(map car dependencies+versions)))
+ (module-path-sans-suffix
+ (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path)))
(guix-name (go-module->guix-package-name module-path))
(root-module-path (module-path->repository-root module-path))
;; The VCS type and URL are not included in goproxy information. For
@@ -619,7 +621,7 @@ hint: use one of the following available versions ~a\n"
(meta-data (fetch-module-meta-data root-module-path))
(vcs-type (module-meta-vcs meta-data))
(vcs-repo-url (module-meta-data-repo-url meta-data goproxy))
- (synopsis (go-package-synopsis root-module-path))
+ (synopsis (go-package-synopsis module-path))
(description (go-package-description module-path))
(licenses (go-package-licenses module-path)))
(values
@@ -630,7 +632,10 @@ hint: use one of the following available versions ~a\n"
,(vcs->origin vcs-type vcs-repo-url version*))
(build-system go-build-system)
(arguments
- '(#:import-path ,root-module-path))
+ '(#:import-path ,module-path
+ ,@(if (string=? module-path-sans-suffix root-module-path)
+ '()
+ `(#:unpack-path ,root-module-path))))
,@(maybe-propagated-inputs
(map (match-lambda
((name version)
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 7c6d9d0a22..d73fbe6a81 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -55,8 +55,8 @@
hackage-package?))
(define ghc-standard-libraries
- ;; List of libraries distributed with ghc (8.6.5).
- ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5.
+ ;; List of libraries distributed with ghc (as of 8.10.7).
+ ;; Contents of …-ghc-8.10.7/lib/ghc-8.10.7
'("ghc"
"cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
;; hackage-name->package-name takes this into account.
@@ -68,6 +68,7 @@
"containers"
"deepseq"
"directory"
+ "exceptions"
"filepath"
"ghc"
"ghc-boot"
@@ -121,12 +122,12 @@ version is returned."
(string-append package-name-prefix (string-downcase name))))
(define guix-package->hackage-name
- (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*"))
+ (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*"))
(name-rx (make-regexp "(.*)-[0-9\\.]+")))
(lambda (package)
"Given a Guix package name, return the corresponding Hackage name."
(let* ((source-url (and=> (package-source package) origin-uri))
- (name (match:substring (regexp-exec uri-rx source-url) 1)))
+ (name (match:substring (regexp-exec uri-rx source-url) 2)))
(match (regexp-exec name-rx name)
(#f name)
(m (match:substring m 1)))))))
@@ -351,7 +352,7 @@ respectively."
#:guix-name hackage-name->package-name))
(define hackage-package?
- (let ((hackage-rx (make-regexp "https?://hackage.haskell.org")))
+ (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)")))
(url-predicate (cut regexp-exec hackage-rx <>))))
(define (latest-release package)
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index e1f8487b75..0f3ab473ca 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -25,6 +25,8 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module ((guix packages) #:prefix package:)
+ #:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module (guix i18n)
@@ -36,15 +38,19 @@
#:use-module (json)
#:use-module (guix base32)
#:use-module (guix git)
+ #:use-module ((guix git-download) #:prefix download:)
#:use-module (guix store)
#:export (%default-sort-key
%contentdb-api
json->package
contentdb-fetch
elaborate-contentdb-name
+ minetest-package?
+ latest-minetest-release
minetest->guix-package
minetest-recursive-import
- sort-packages))
+ sort-packages
+ %minetest-updater))
;; The ContentDB API is documented at
;; <https://content.minetest.net>.
@@ -203,7 +209,7 @@ raise an exception."
(match correctly-named
((one) (package-keys-full-name one))
((too . many)
- (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%")
+ (warning (G_ "~a is ambiguous, presuming ~a (other options include: ~a)~%")
name (package-keys-full-name too)
(map package-keys-full-name many))
(package-keys-full-name too))
@@ -256,7 +262,7 @@ and possibly some other packages as well, or #f on failure."
(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
+be \"mod\", \"game\" or \"txp\", restricting the search results to
respectively mods, games and texture packs. Limit to at most LIMIT
results. The return value is a list of <package-keys> records."
;; XXX does Guile have something for constructing (and, when necessary,
@@ -337,6 +343,25 @@ official Minetest forum and the Git repository (if any)."
(and=> (package-forums package) topic->url-sexp)
(package-repository package)))
+(define (release-version release)
+ "Guess the version of RELEASE from the release title."
+ (define title (release-title release))
+ (if (string-prefix? "v" title)
+ ;; Remove "v" prefix from release titles like ‘v1.0.1’.
+ (substring title 1)
+ title))
+
+(define (version-style version)
+ "Determine the kind of version number VERSION is -- a date, or a conventional
+conventional version number."
+ (define dots? (->bool (string-index version #\.)))
+ (define hyphens? (->bool (string-index version #\-)))
+ (match (cons dots? hyphens?)
+ ((#true . #false) 'regular) ; something like "0.1"
+ ((#false . #false) 'regular) ; single component version number
+ ((#true . #true) 'regular) ; result of 'git-version'
+ ((#false . #true) 'date))) ; something like "2021-01-25"
+
;; If the default sort key is changed, make sure to modify 'show-help'
;; in (guix scripts import minetest) appropriately as well.
(define %default-sort-key "score")
@@ -371,7 +396,11 @@ official Minetest forum and the Git repository (if any)."
DEPENDENCIES as a list of AUTHOR/NAME strings."
(define dependency-list
(assoc-ref dependencies author/name))
- (filter-map
+ ;; A mod can have multiple dependencies implemented by the same mod,
+ ;; so remove duplicate mod names.
+ (define (filter-deduplicate-map f list)
+ (delete-duplicates (filter-map f list)))
+ (filter-deduplicate-map
(lambda (dependency)
(and (not (dependency-optional? dependency))
(not (builtin-mod? (dependency-name dependency)))
@@ -432,7 +461,7 @@ list of AUTHOR/NAME strings."
(define important-upstream-dependencies
(important-dependencies dependencies author/name #:sort sort))
(values (make-minetest-sexp author/name
- (release-title release) ; version
+ (release-version release)
(package-repository package)
(release-commit release)
important-upstream-dependencies
@@ -454,3 +483,37 @@ list of AUTHOR/NAME strings."
(recursive-import author/name
#:repo->guix-package minetest->guix-package*
#:guix-name contentdb->package-name))
+
+(define (minetest-package? pkg)
+ "Is PKG a Minetest mod on ContentDB?"
+ (and (string-prefix? "minetest-" (package:package-name pkg))
+ (assq-ref (package:package-properties pkg) 'upstream-name)))
+
+(define (latest-minetest-release pkg)
+ "Return an <upstream-source> for the latest release of the package PKG,
+or #false if the latest release couldn't be determined."
+ (define author/name
+ (assq-ref (package:package-properties pkg) 'upstream-name))
+ (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f?
+ (define release (latest-release author/name))
+ (define source (package:package-source pkg))
+ (and contentdb-package release
+ (release-commit release) ; not always set
+ ;; Only continue if both the old and new version number are both
+ ;; dates or regular version numbers, as two different styles confuses
+ ;; the logic for determining which version is newer.
+ (eq? (version-style (release-version release))
+ (version-style (package:package-version pkg)))
+ (upstream-source
+ (package (package:package-name pkg))
+ (version (release-version release))
+ (urls (list (download:git-reference
+ (url (package-repository contentdb-package))
+ (commit (release-commit release))))))))
+
+(define %minetest-updater
+ (upstream-updater
+ (name 'minetest)
+ (description "Updater for Minetest packages on ContentDB")
+ (pred minetest-package?)
+ (latest latest-minetest-release)))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index f3619dcd9e..e2314820d0 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -9,6 +9,7 @@
;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -163,12 +164,13 @@ package on PyPI."
(hyphen-package-name->name+version
(basename (file-sans-extension url))))
- (match (and=> (package-source package) origin-uri)
- ((? string? url)
- (url->pypi-name url))
- ((lst ...)
- (any url->pypi-name lst))
- (#f #f)))
+ (or (assoc-ref (package-properties package) 'upstream-name)
+ (match (and=> (package-source package) origin-uri)
+ ((? string? url)
+ (url->pypi-name url))
+ ((lst ...)
+ (any url->pypi-name lst))
+ (#f #f))))
(define (wheel-url->extracted-directory wheel-url)
(match (string-split (basename wheel-url) #\-)
@@ -416,6 +418,11 @@ return the unaltered list of upstream dependency names."
description license)
"Return the `package' s-expression for a python package with the given NAME,
VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
+ (define (maybe-upstream-name name)
+ (if (string-match ".*\\-[0-9]+" (pk name))
+ `((properties ,`'(("upstream-name" . ,name))))
+ '()))
+
(call-with-temporary-output-file
(lambda (temp port)
(and (url-fetch source-url temp)
@@ -454,6 +461,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(sha256
(base32
,(guix-hash-url temp)))))
+ ,@(maybe-upstream-name name)
(build-system python-build-system)
,@(maybe-inputs required-inputs 'propagated-inputs)
,@(maybe-inputs native-inputs 'native-inputs)
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index bbd903a2cd..f58c6b163d 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -2,6 +2,8 @@
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,9 +22,8 @@
(define-module (guix import stackage)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (guix import json)
@@ -31,6 +32,8 @@
#:use-module (guix memoization)
#:use-module (guix packages)
#:use-module (guix upstream)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:export (%stackage-url
stackage->guix-package
stackage-recursive-import
@@ -44,15 +47,31 @@
(define %stackage-url
(make-parameter "https://www.stackage.org"))
-;; Latest LTS version compatible with GHC 8.6.5.
-(define %default-lts-version "14.27")
-
-(define (lts-info-packages lts-info)
- "Returns the alist of packages contained in LTS-INFO."
- (or (assoc-ref lts-info "packages") '()))
-
-(define (leave-with-message fmt . args)
- (raise (condition (&message (message (apply format #f fmt args))))))
+;; Latest LTS version compatible with current GHC.
+(define %default-lts-version "18.10")
+
+(define-json-mapping <stackage-lts> make-stackage-lts
+ stackage-lts?
+ json->stackage-lts
+ (snapshot stackage-lts-snapshot "snapshot" json->snapshot)
+ (packages stackage-lts-packages "packages"
+ (lambda (vector)
+ (map json->stackage-package (vector->list vector)))))
+
+(define-json-mapping <snapshot> make-snapshot
+ stackage-snapshot?
+ json->snapshot
+ (name snapshot-name)
+ (ghc-version snapshot-ghc-version)
+ (compiler snapshot-compiler))
+
+(define-json-mapping <stackage-package> make-stackage-package
+ stackage-package?
+ json->stackage-package
+ (origin stackage-package-origin)
+ (name stackage-package-name)
+ (version stackage-package-version)
+ (synopsis stackage-package-synopsis))
(define stackage-lts-info-fetch
;; "Retrieve the information about the LTS Stackage release VERSION."
@@ -62,21 +81,15 @@
"/lts-" (if (string-null? version)
%default-lts-version
version)))
- (lts-info (json-fetch url)))
- (if lts-info
- (reverse lts-info)
- (leave-with-message "LTS release version not found: ~a" version))))))
-
-(define (stackage-package-name pkg-info)
- (assoc-ref pkg-info "name"))
-
-(define (stackage-package-version pkg-info)
- (assoc-ref pkg-info "version"))
+ (lts-info (and=> (json-fetch url) json->stackage-lts)))
+ (or lts-info
+ (raise (formatted-message (G_ "LTS release version not found: ~a")
+ version)))))))
-(define (lts-package-version pkgs-info name)
- "Return the version of the package with upstream NAME included in PKGS-INFO."
+(define (lts-package-version packages name)
+ "Return the version of the package with upstream NAME included in PACKAGES."
(let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
- (vector->list pkgs-info))))
+ packages)))
(stackage-package-version pkg)))
@@ -93,21 +106,22 @@
#:key
(include-test-dependencies? #t)
(lts-version %default-lts-version)
- (packages-info
- (lts-info-packages
+ (packages
+ (stackage-lts-packages
(stackage-lts-info-fetch lts-version))))
"Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved
version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
release at stackage.org. Return the `package' S-expression corresponding to
that package, or #f on failure. PACKAGES-INFO is the alist with the packages
included in the Stackage LTS release."
- (let* ((version (lts-package-version packages-info package-name))
+ (let* ((version (lts-package-version packages package-name))
(name-version (hackage-name-version package-name version)))
(if name-version
(hackage->guix-package name-version
#:include-test-dependencies?
include-test-dependencies?)
- (leave-with-message "~a: Stackage package not found" package-name))))))
+ (raise (formatted-message (G_ "~a: Stackage package not found")
+ package-name)))))))
(define (stackage-recursive-import package-name . args)
(recursive-import package-name
@@ -121,31 +135,46 @@ included in the Stackage LTS release."
;;;
(define latest-lts-release
- (let ((pkgs-info
- (mlambda () (lts-info-packages
- (stackage-lts-info-fetch %default-lts-version)))))
- (lambda* (package)
+ (let ((packages
+ (mlambda ()
+ (stackage-lts-packages
+ (stackage-lts-info-fetch %default-lts-version)))))
+ (lambda* (pkg)
"Return an <upstream-source> for the latest Stackage LTS release of
PACKAGE or #f if the package is not included in the Stackage LTS release."
- (let* ((hackage-name (guix-package->hackage-name package))
- (version (lts-package-version (pkgs-info) hackage-name))
+ (let* ((hackage-name (guix-package->hackage-name pkg))
+ (version (lts-package-version (packages) hackage-name))
(name-version (hackage-name-version hackage-name version)))
(match (and=> name-version hackage-fetch)
- (#f (format (current-error-port)
- "warning: failed to parse ~a~%"
- (hackage-cabal-url hackage-name))
- #f)
+ (#f
+ (warning (G_ "failed to parse ~a~%")
+ (hackage-cabal-url hackage-name))
+ #f)
(_ (let ((url (hackage-source-url hackage-name version)))
(upstream-source
- (package (package-name package))
+ (package (package-name pkg))
(version version)
- (urls (list url))))))))))
+ (urls (list url))
+ (input-changes
+ (changed-inputs
+ pkg
+ (stackage->guix-package hackage-name #:packages (packages))))))))))))
+
+(define (stackage-lts-package? package)
+ "Return whether PACKAGE is available on the default Stackage LTS release."
+ (and (hackage-package? package)
+ (let ((packages (stackage-lts-packages
+ (stackage-lts-info-fetch %default-lts-version)))
+ (hackage-name (guix-package->hackage-name package)))
+ (find (lambda (package)
+ (string=? (stackage-package-name package) hackage-name))
+ packages))))
(define %stackage-updater
(upstream-updater
(name 'stackage)
(description "Updater for Stackage LTS packages")
- (pred hackage-package?)
+ (pred stackage-lts-package?)
(latest latest-lts-release)))
;;; stackage.scm ends here