mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
maint: Switch to Guile-JSON 3.x.
Guile-JSON 3.x is incompatible with Guile-JSON 1.x, which we relied on
until now: it maps JSON dictionaries to alists (instead of hash tables),
and JSON arrays to vectors (instead of lists). This commit is about
adjusting all the existing code to this new mapping.
* m4/guix.m4 (GUIX_CHECK_GUILE_JSON): New macro.
* configure.ac: Use it.
* doc/guix.texi (Requirements): Mention the Guile-JSON version.
* guix/git-download.scm (git-fetch)[guile-json]: Use GUILE-JSON-3.
* guix/import/cpan.scm (string->license): Expect vectors instead of
lists.
(module->dist-name): Use 'json-fetch' instead of 'json-fetch-alist'.
(cpan-fetch): Likewise.
* guix/import/crate.scm (crate-fetch): Likewise, and call 'vector->list'
for DEPS.
* guix/import/gem.scm (rubygems-fetch): Likewise.
* guix/import/json.scm (json-fetch-alist): Remove.
* guix/import/pypi.scm (pypi-fetch): Use 'json-fetch' instead of
'json-fetch-alist'.
(latest-source-release, latest-wheel-release): Call 'vector->list' on
RELEASES.
* guix/import/stackage.scm (stackage-lts-info-fetch): Use 'json-fetch'
instead of 'json-fetch-alist'.
(lts-package-version): Use 'vector->list'.
* guix/import/utils.scm (hash-table->alist): Remove.
(alist->package): Pass 'vector->list' on the inputs fields, and default
to the empty vector.
* guix/scripts/import/json.scm (guix-import-json): Remove call to
'hash-table->alist'.
* guix/swh.scm (define-json-reader): Expect pair? or null? instead of
hash-table?.
[extract-field]: Use 'assoc-ref' instead of 'hash-ref'.
(json->branches): Use 'map' instead of 'hash-map->list'.
(json->checksums): Likewise.
(json->directory-entries, origin-visits): Call 'vector->list' on the
result of 'json->scm'.
* tests/import-utils.scm ("alist->package with dependencies"): New test.
* gnu/installer.scm (build-compiled-file)[builder]: Use GUILE-JSON-3.
* gnu/installer.scm (installer-program)[installer-builder]: Likewise.
* gnu/installer/locale.scm (iso639->iso639-languages): Use 'assoc-ref'
instead of 'hash-ref', and pass vectors through 'vector->list'.
(iso3166->iso3166-territories): Likewise.
* gnu/system/vm.scm (system-docker-image)[build]: Use GUILE-JSON-3.
* guix/docker.scm (manifest, config): Adjust for Guile-JSON 3.
* guix/scripts/pack.scm (docker-image)[build]: Use GUILE-JSON-3.
* guix/import/github.scm (fetch-releases-or-tags): Update docstring.
(latest-released-version): Use 'assoc-ref' instead of 'hash-ref'. Pass
the result of 'fetch-releases-or-tags' to 'vector->list'.
* guix/import/launchpad.scm (latest-released-version): Likewise.
This commit is contained in:
Ludovic Courtès
parent
a0efa069a1
commit
81c3dc3224
22 changed files with 140 additions and 104 deletions
|
|
@ -119,8 +119,8 @@ if test "x$have_guile_git" != "xyes"; then
|
|||
fi
|
||||
|
||||
dnl Check for Guile-JSON.
|
||||
GUILE_MODULE_AVAILABLE([have_guile_json], [(json)])
|
||||
if test "x$have_guile_json" != "xyes"; then
|
||||
GUIX_CHECK_GUILE_JSON
|
||||
if test "x$guix_cv_have_recent_guile_json" != "xyes"; then
|
||||
AC_MSG_ERROR([Guile-JSON is missing; please install it.])
|
||||
fi
|
||||
|
||||
|
|
|
|||
|
|
@ -750,7 +750,7 @@ or later;
|
|||
@c FIXME: Specify a version number once a release has been made.
|
||||
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
|
||||
2017 or later;
|
||||
@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON};
|
||||
@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x;
|
||||
@item @url{https://zlib.net, zlib};
|
||||
@item @url{https://www.gnu.org/software/make/, GNU Make}.
|
||||
@end itemize
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ (define set-utf8-locale
|
|||
(setlocale LC_ALL "en_US.utf8")))
|
||||
|
||||
(define builder
|
||||
(with-extensions (list guile-json)
|
||||
(with-extensions (list guile-json-3)
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu installer locale)))
|
||||
#~(begin
|
||||
|
|
@ -313,7 +313,7 @@ (define installer-builder
|
|||
;; packages …), etc. modules.
|
||||
(with-extensions (list guile-gcrypt guile-newt
|
||||
guile-parted guile-bytestructures
|
||||
guile-json guile-git guix)
|
||||
guile-json-3 guile-git guix)
|
||||
(with-imported-modules `(,@(source-module-closure
|
||||
`(,@modules
|
||||
(gnu services herd)
|
||||
|
|
|
|||
|
|
@ -134,16 +134,18 @@ (define (iso639->iso639-languages locales iso639-3 iso639-5)
|
|||
(lambda (port-iso639-5)
|
||||
(filter-map
|
||||
(lambda (hash)
|
||||
(let ((alpha2 (hash-ref hash "alpha_2"))
|
||||
(alpha3 (hash-ref hash "alpha_3"))
|
||||
(name (hash-ref hash "name")))
|
||||
(let ((alpha2 (assoc-ref hash "alpha_2"))
|
||||
(alpha3 (assoc-ref hash "alpha_3"))
|
||||
(name (assoc-ref hash "name")))
|
||||
(and (supported-locale? locales alpha2 alpha3)
|
||||
`((alpha2 . ,alpha2)
|
||||
(alpha3 . ,alpha3)
|
||||
(name . ,name)))))
|
||||
(append
|
||||
(hash-ref (json->scm port-iso639-3) "639-3")
|
||||
(hash-ref (json->scm port-iso639-5) "639-5"))))))))
|
||||
(vector->list
|
||||
(assoc-ref (json->scm port-iso639-3) "639-3"))
|
||||
(vector->list
|
||||
(assoc-ref (json->scm port-iso639-5) "639-5")))))))))
|
||||
|
||||
(define (language-code->language-name languages language-code)
|
||||
"Using LANGUAGES as a list of ISO639 association lists, return the language
|
||||
|
|
@ -179,10 +181,11 @@ (define (iso3166->iso3166-territories iso3166)
|
|||
(call-with-input-file iso3166
|
||||
(lambda (port)
|
||||
(map (lambda (hash)
|
||||
`((alpha2 . ,(hash-ref hash "alpha_2"))
|
||||
(alpha3 . ,(hash-ref hash "alpha_3"))
|
||||
(name . ,(hash-ref hash "name"))))
|
||||
(hash-ref (json->scm port) "3166-1")))))
|
||||
`((alpha2 . ,(assoc-ref hash "alpha_2"))
|
||||
(alpha3 . ,(assoc-ref hash "alpha_3"))
|
||||
(name . ,(assoc-ref hash "name"))))
|
||||
(vector->list
|
||||
(assoc-ref (json->scm port) "3166-1"))))))
|
||||
|
||||
(define (territory-code->territory-name territories territory-code)
|
||||
"Using TERRITORIES as a list of ISO3166 association lists return the
|
||||
|
|
|
|||
|
|
@ -514,7 +514,7 @@ (define boot-program
|
|||
(name (string-append name ".tar.gz"))
|
||||
(graph "system-graph"))
|
||||
(define build
|
||||
(with-extensions (cons guile-json ;for (guix docker)
|
||||
(with-extensions (cons guile-json-3 ;for (guix docker)
|
||||
gcrypt-sqlite3&co) ;for (guix store database)
|
||||
(with-imported-modules `(,@(source-module-closure
|
||||
'((guix docker)
|
||||
|
|
|
|||
|
|
@ -62,9 +62,9 @@ (define (generate-tag path)
|
|||
|
||||
(define (manifest path id)
|
||||
"Generate a simple image manifest."
|
||||
`(((Config . "config.json")
|
||||
(RepoTags . (,(generate-tag path)))
|
||||
(Layers . (,(string-append id "/layer.tar"))))))
|
||||
`#(((Config . "config.json")
|
||||
(RepoTags . #(,(generate-tag path)))
|
||||
(Layers . #(,(string-append id "/layer.tar"))))))
|
||||
|
||||
;; According to the specifications this is required for backwards
|
||||
;; compatibility. It duplicates information provided by the manifest.
|
||||
|
|
@ -81,17 +81,18 @@ (define* (config layer time arch #:key entry-point (environment '()))
|
|||
`((architecture . ,arch)
|
||||
(comment . "Generated by GNU Guix")
|
||||
(created . ,time)
|
||||
(config . ,`((env . ,(map (match-lambda
|
||||
((name . value)
|
||||
(string-append name "=" value)))
|
||||
environment))
|
||||
(config . ,`((env . ,(list->vector
|
||||
(map (match-lambda
|
||||
((name . value)
|
||||
(string-append name "=" value)))
|
||||
environment)))
|
||||
,@(if entry-point
|
||||
`((entrypoint . ,entry-point))
|
||||
`((entrypoint . ,(list->vector entry-point)))
|
||||
'())))
|
||||
(container_config . #nil)
|
||||
(os . "linux")
|
||||
(rootfs . ((type . "layers")
|
||||
(diff_ids . (,(layer-diff-id layer)))))))
|
||||
(diff_ids . #(,(layer-diff-id layer)))))))
|
||||
|
||||
(define %tar-determinism-options
|
||||
;; GNU tar options to produce archives deterministically.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
|
||||
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
|
||||
;;;
|
||||
|
|
@ -85,7 +85,7 @@ (define zlib
|
|||
(module-ref (resolve-interface '(gnu packages compression)) 'zlib))
|
||||
|
||||
(define guile-json
|
||||
(module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
|
||||
(module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3))
|
||||
|
||||
(define gnutls
|
||||
(module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
|
||||
|
|
|
|||
|
|
@ -76,8 +76,8 @@ (define string->license
|
|||
;; ssleay
|
||||
;; sun
|
||||
("zlib" 'zlib)
|
||||
((x) (string->license x))
|
||||
((lst ...) `(list ,@(map string->license lst)))
|
||||
(#(x) (string->license x))
|
||||
(#(lst ...) `(list ,@(map string->license lst)))
|
||||
(_ #f)))
|
||||
|
||||
(define (module->name module)
|
||||
|
|
@ -88,10 +88,10 @@ (define (module->dist-name module)
|
|||
"Return the base distribution module for a given module. E.g. the 'ok'
|
||||
module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
|
||||
return \"Test-Simple\""
|
||||
(assoc-ref (json-fetch-alist (string-append
|
||||
"https://fastapi.metacpan.org/v1/module/"
|
||||
module
|
||||
"?fields=distribution"))
|
||||
(assoc-ref (json-fetch (string-append
|
||||
"https://fastapi.metacpan.org/v1/module/"
|
||||
module
|
||||
"?fields=distribution"))
|
||||
"distribution"))
|
||||
|
||||
(define (package->upstream-name package)
|
||||
|
|
@ -114,7 +114,7 @@ (define (cpan-fetch name)
|
|||
"Return an alist representation of the CPAN metadata for the perl module MODULE,
|
||||
or #f on failure. MODULE should be e.g. \"Test::Script\""
|
||||
;; This API always returns the latest release of the module.
|
||||
(json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
|
||||
(json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
|
||||
|
||||
(define (cpan-home name)
|
||||
(string-append "https://metacpan.org/release/" name))
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ (define (string->license string)
|
|||
(define (crate-kind-predicate kind)
|
||||
(lambda (dep) (string=? (assoc-ref dep "kind") kind)))
|
||||
|
||||
(and-let* ((crate-json (json-fetch-alist (string-append crate-url crate-name)))
|
||||
(and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
|
||||
(crate (assoc-ref crate-json "crate"))
|
||||
(name (assoc-ref crate "name"))
|
||||
(version (assoc-ref crate "max_version"))
|
||||
|
|
@ -63,8 +63,8 @@ (define (crate-kind-predicate kind)
|
|||
string->license)
|
||||
'())) ;missing license info
|
||||
(path (string-append "/" version "/dependencies"))
|
||||
(deps-json (json-fetch-alist (string-append crate-url name path)))
|
||||
(deps (assoc-ref deps-json "dependencies"))
|
||||
(deps-json (json-fetch (string-append crate-url name path)))
|
||||
(deps (vector->list (assoc-ref deps-json "dependencies")))
|
||||
(dep-crates (filter (crate-kind-predicate "normal") deps))
|
||||
(dev-dep-crates
|
||||
(filter (lambda (dep)
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ (define-module (guix import gem)
|
|||
(define (rubygems-fetch name)
|
||||
"Return an alist representation of the RubyGems metadata for the package NAME,
|
||||
or #f on failure."
|
||||
(json-fetch-alist
|
||||
(json-fetch
|
||||
(string-append "https://rubygems.org/api/v1/gems/" name ".json")))
|
||||
|
||||
(define (ruby-package-name name)
|
||||
|
|
@ -130,14 +130,18 @@ (define* (gem->guix-package package-name #:optional (repo 'rubygems) version)
|
|||
(assoc-ref package "info")))
|
||||
(home-page (assoc-ref package "homepage_uri"))
|
||||
(dependencies-names (map (lambda (dep) (assoc-ref dep "name"))
|
||||
(assoc-ref* package "dependencies" "runtime")))
|
||||
(vector->list
|
||||
(assoc-ref* package
|
||||
"dependencies"
|
||||
"runtime"))))
|
||||
(dependencies (map (lambda (dep)
|
||||
(if (string=? dep "bundler")
|
||||
"bundler" ; special case, no prefix
|
||||
(ruby-package-name dep)))
|
||||
dependencies-names))
|
||||
(licenses (map string->license
|
||||
(assoc-ref package "licenses"))))
|
||||
(vector->list
|
||||
(assoc-ref package "licenses")))))
|
||||
(values (make-gem-sexp name version hash home-page synopsis
|
||||
description dependencies licenses)
|
||||
dependencies-names)))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
|
||||
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
|
||||
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
|
||||
;;;
|
||||
|
|
@ -130,7 +130,7 @@ (define %github-token
|
|||
|
||||
(define (fetch-releases-or-tags url)
|
||||
"Fetch the list of \"releases\" or, if it's empty, the list of tags for the
|
||||
repository at URL. Return the corresponding JSON dictionaries (hash tables),
|
||||
repository at URL. Return the corresponding JSON dictionaries (alists),
|
||||
or #f if the information could not be retrieved.
|
||||
|
||||
We look at both /releases and /tags because the \"release\" feature of GitHub
|
||||
|
|
@ -172,11 +172,11 @@ (define (latest-released-version url package-name)
|
|||
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
|
||||
the package e.g. 'bedtools2'. Return #f if there is no releases"
|
||||
(define (pre-release? x)
|
||||
(hash-ref x "prerelease"))
|
||||
(assoc-ref x "prerelease"))
|
||||
|
||||
(define (release->version release)
|
||||
(let ((tag (or (hash-ref release "tag_name") ;a "release"
|
||||
(hash-ref release "name"))) ;a tag
|
||||
(let ((tag (or (assoc-ref release "tag_name") ;a "release"
|
||||
(assoc-ref release "name"))) ;a tag
|
||||
(name-length (string-length package-name)))
|
||||
(cond
|
||||
;; some tags include the name of the package e.g. "fdupes-1.51"
|
||||
|
|
@ -197,7 +197,8 @@ (define (release->version release)
|
|||
tag)
|
||||
(else #f))))
|
||||
|
||||
(let* ((json (fetch-releases-or-tags url)))
|
||||
(let* ((json (and=> (fetch-releases-or-tags url)
|
||||
vector->list)))
|
||||
(if (eq? json #f)
|
||||
(if (%github-token)
|
||||
(error "Error downloading release information through the GitHub
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014 David Thompson <davet@gnu.org>
|
||||
;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
|
||||
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -23,8 +23,7 @@ (define-module (guix import json)
|
|||
#:use-module (guix http-client)
|
||||
#:use-module (guix import utils)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:export (json-fetch
|
||||
json-fetch-alist))
|
||||
#:export (json-fetch))
|
||||
|
||||
(define* (json-fetch url
|
||||
;; Note: many websites returns 403 if we omit a
|
||||
|
|
@ -43,9 +42,3 @@ (define* (json-fetch url
|
|||
(result (json->scm port)))
|
||||
(close-port port)
|
||||
result)))
|
||||
|
||||
(define (json-fetch-alist url)
|
||||
"Return an alist representation of the JSON resource URL, or #f if URL
|
||||
returns 403 or 404."
|
||||
(and=> (json-fetch url)
|
||||
hash-table->alist))
|
||||
|
|
|
|||
|
|
@ -87,15 +87,16 @@ (define (pre-release? x)
|
|||
;; example, "5.1.0-rc1") are assumed to be pre-releases.
|
||||
(not (string-every (char-set-union (char-set #\.)
|
||||
char-set:digit)
|
||||
(hash-ref x "version"))))
|
||||
(assoc-ref x "version"))))
|
||||
|
||||
(hash-ref
|
||||
(assoc-ref
|
||||
(last (remove
|
||||
pre-release?
|
||||
(hash-ref (json-fetch
|
||||
(string-append "https://api.launchpad.net/1.0/"
|
||||
package-name "/releases"))
|
||||
"entries")))
|
||||
(vector->list
|
||||
(assoc-ref (json-fetch
|
||||
(string-append "https://api.launchpad.net/1.0/"
|
||||
package-name "/releases"))
|
||||
"entries"))))
|
||||
"version"))
|
||||
|
||||
(define (latest-release pkg)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014 David Thompson <davet@gnu.org>
|
||||
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
|
||||
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
|
|
@ -56,7 +56,7 @@ (define-module (guix import pypi)
|
|||
(define (pypi-fetch name)
|
||||
"Return an alist representation of the PyPI metadata for the package NAME,
|
||||
or #f on failure."
|
||||
(json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json")))
|
||||
(json-fetch (string-append "https://pypi.org/pypi/" name "/json")))
|
||||
|
||||
;; For packages found on PyPI that lack a source distribution.
|
||||
(define-condition-type &missing-source-error &error
|
||||
|
|
@ -69,7 +69,7 @@ (define (latest-source-release pypi-package)
|
|||
(assoc-ref* pypi-package "info" "version"))))
|
||||
(or (find (lambda (release)
|
||||
(string=? "sdist" (assoc-ref release "packagetype")))
|
||||
releases)
|
||||
(vector->list releases))
|
||||
(raise (condition (&missing-source-error
|
||||
(package pypi-package)))))))
|
||||
|
||||
|
|
@ -80,7 +80,7 @@ (define (latest-wheel-release pypi-package)
|
|||
(assoc-ref* pypi-package "info" "version"))))
|
||||
(or (find (lambda (release)
|
||||
(string=? "bdist_wheel" (assoc-ref release "packagetype")))
|
||||
releases)
|
||||
(vector->list releases))
|
||||
#f)))
|
||||
|
||||
(define (python->package-name name)
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ (define stackage-lts-info-fetch
|
|||
(let* ((url (if (string=? "" version)
|
||||
(string-append %stackage-url "/lts")
|
||||
(string-append %stackage-url "/lts-" version)))
|
||||
(lts-info (json-fetch-alist url)))
|
||||
(lts-info (json-fetch url)))
|
||||
(if lts-info
|
||||
(reverse lts-info)
|
||||
(leave-with-message "LTS release version not found: ~a" version))))))
|
||||
|
|
@ -74,7 +74,7 @@ (define (stackage-package-version pkg-info)
|
|||
(define (lts-package-version pkgs-info name)
|
||||
"Return the version of the package with upstream NAME included in PKGS-INFO."
|
||||
(let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
|
||||
pkgs-info)))
|
||||
(vector->list pkgs-info))))
|
||||
(stackage-package-version pkg)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,6 @@ (define-module (guix import utils)
|
|||
#:use-module (srfi srfi-41)
|
||||
#:export (factorize-uri
|
||||
|
||||
hash-table->alist
|
||||
flatten
|
||||
assoc-ref*
|
||||
|
||||
|
|
@ -100,21 +99,6 @@ (define (factorize-uri uri version)
|
|||
'()
|
||||
indices))))))
|
||||
|
||||
(define (hash-table->alist table)
|
||||
"Return an alist represenation of TABLE."
|
||||
(map (match-lambda
|
||||
((key . (lst ...))
|
||||
(cons key
|
||||
(map (lambda (x)
|
||||
(if (hash-table? x)
|
||||
(hash-table->alist x)
|
||||
x))
|
||||
lst)))
|
||||
((key . (? hash-table? table))
|
||||
(cons key (hash-table->alist table)))
|
||||
(pair pair))
|
||||
(hash-map->list cons table)))
|
||||
|
||||
(define (flatten lst)
|
||||
"Return a list that recursively concatenates all sub-lists of LST."
|
||||
(fold-right
|
||||
|
|
@ -330,11 +314,14 @@ (define (alist->package meta)
|
|||
(lookup-build-system-by-name
|
||||
(string->symbol (assoc-ref meta "build-system"))))
|
||||
(native-inputs
|
||||
(specs->package-lists (or (assoc-ref meta "native-inputs") '())))
|
||||
(specs->package-lists
|
||||
(vector->list (or (assoc-ref meta "native-inputs") '#()))))
|
||||
(inputs
|
||||
(specs->package-lists (or (assoc-ref meta "inputs") '())))
|
||||
(specs->package-lists
|
||||
(vector->list (or (assoc-ref meta "inputs") '#()))))
|
||||
(propagated-inputs
|
||||
(specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
|
||||
(specs->package-lists
|
||||
(vector->list (or (assoc-ref meta "propagated-inputs") '#()))))
|
||||
(home-page
|
||||
(assoc-ref meta "home-page"))
|
||||
(synopsis
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ (define (parse-options)
|
|||
(let ((json (json-string->scm
|
||||
(with-input-from-file file-name read-string))))
|
||||
;; TODO: also print define-module boilerplate
|
||||
(package->code (alist->package (hash-table->alist json)))))
|
||||
(package->code (alist->package json))))
|
||||
(lambda _
|
||||
(leave (G_ "invalid JSON in file '~a'~%") file-name))))
|
||||
(()
|
||||
|
|
|
|||
|
|
@ -479,7 +479,7 @@ (define defmod 'define-module) ;trick Geiser
|
|||
|
||||
(define build
|
||||
;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
|
||||
(with-extensions (list guile-json guile-gcrypt)
|
||||
(with-extensions (list guile-json-3 guile-gcrypt)
|
||||
(with-imported-modules `(((guix config) => ,(make-config.scm))
|
||||
,@(source-module-closure
|
||||
`((guix docker)
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ (define specification->package
|
|||
(module-ref (resolve-interface module) variable))))
|
||||
(match-lambda
|
||||
("guile" (ref '(gnu packages commencement) 'guile-final))
|
||||
("guile-json" (ref '(gnu packages guile) 'guile-json))
|
||||
("guile-json" (ref '(gnu packages guile) 'guile-json-3))
|
||||
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
|
||||
("guile-git" (ref '(gnu packages guile) 'guile-git))
|
||||
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
|
||||
|
|
|
|||
35
guix/swh.scm
35
guix/swh.scm
|
|
@ -138,16 +138,16 @@ (define (json->record input)
|
|||
(json->scm input))
|
||||
((string? input)
|
||||
(json-string->scm input))
|
||||
((hash-table? input)
|
||||
((or (null? input) (pair? input))
|
||||
input))))
|
||||
(let-syntax ((extract-field (syntax-rules ()
|
||||
((_ table (field key json->value))
|
||||
(json->value (hash-ref table key)))
|
||||
(json->value (assoc-ref table key)))
|
||||
((_ table (field key))
|
||||
(hash-ref table key))
|
||||
(assoc-ref table key))
|
||||
((_ table (field))
|
||||
(hash-ref table
|
||||
(symbol->string 'field))))))
|
||||
(assoc-ref table
|
||||
(symbol->string 'field))))))
|
||||
(ctor (extract-field table spec) ...)))))
|
||||
|
||||
(define-syntax-rule (define-json-mapping rtd ctor pred json->record
|
||||
|
|
@ -257,12 +257,13 @@ (define-record-type <branch>
|
|||
(target-url branch-target-url))
|
||||
|
||||
(define (json->branches branches)
|
||||
(hash-map->list (lambda (key value)
|
||||
(make-branch key
|
||||
(string->symbol
|
||||
(hash-ref value "target_type"))
|
||||
(hash-ref value "target_url")))
|
||||
branches))
|
||||
(map (match-lambda
|
||||
((key . value)
|
||||
(make-branch key
|
||||
(string->symbol
|
||||
(assoc-ref value "target_type"))
|
||||
(assoc-ref value "target_url"))))
|
||||
branches))
|
||||
|
||||
;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/>
|
||||
(define-json-mapping <release> make-release release?
|
||||
|
|
@ -292,9 +293,10 @@ (define-json-mapping <content> make-content content?
|
|||
(license-url content-license-url "license_url"))
|
||||
|
||||
(define (json->checksums checksums)
|
||||
(hash-map->list (lambda (key value)
|
||||
(cons key (base16-string->bytevector value)))
|
||||
checksums))
|
||||
(map (match-lambda
|
||||
((key . value)
|
||||
(cons key (base16-string->bytevector value))))
|
||||
checksums))
|
||||
|
||||
;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/>
|
||||
(define-json-mapping <directory-entry> make-directory-entry directory-entry?
|
||||
|
|
@ -365,14 +367,15 @@ (define-query (lookup-directory id)
|
|||
json->directory-entries)
|
||||
|
||||
(define (json->directory-entries port)
|
||||
(map json->directory-entry (json->scm port)))
|
||||
(map json->directory-entry
|
||||
(vector->list (json->scm port))))
|
||||
|
||||
(define (origin-visits origin)
|
||||
"Return the list of visits of ORIGIN, a record as returned by
|
||||
'lookup-origin'."
|
||||
(call (swh-url (origin-visits-url origin))
|
||||
(lambda (port)
|
||||
(map json->visit (json->scm port)))))
|
||||
(map json->visit (vector->list (json->scm port))))))
|
||||
|
||||
(define (visit-snapshot visit)
|
||||
"Return the snapshot corresponding to VISIT."
|
||||
|
|
|
|||
21
m4/guix.m4
21
m4/guix.m4
|
|
@ -174,6 +174,27 @@ AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [
|
|||
fi])
|
||||
])
|
||||
|
||||
dnl GUIX_CHECK_GUILE_JSON
|
||||
dnl
|
||||
dnl Check whether a recent-enough Guile-JSON is available.
|
||||
AC_DEFUN([GUIX_CHECK_GUILE_JSON], [
|
||||
dnl Check whether we're using Guile-JSON 3.x, which uses a JSON-to-Scheme
|
||||
dnl mapping different from that of earlier versions.
|
||||
AC_CACHE_CHECK([whether Guile-JSON is available and recent enough],
|
||||
[guix_cv_have_recent_guile_json],
|
||||
[GUILE_CHECK([retval],
|
||||
[(use-modules (json) (ice-9 match))
|
||||
(match (json-string->scm \"[[] { \\\"a\\\": 42 } []]\")
|
||||
(#(("a" . 42)) #t)
|
||||
(_ #f))])
|
||||
if test "$retval" = 0; then
|
||||
guix_cv_have_recent_guile_json="yes"
|
||||
else
|
||||
guix_cv_have_recent_guile_json="no"
|
||||
fi])
|
||||
])
|
||||
|
||||
|
||||
dnl GUIX_TEST_ROOT_DIRECTORY
|
||||
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
|
||||
AC_CACHE_CHECK([for unit test root directory],
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ (define-module (test-import-utils)
|
|||
#:use-module ((guix licenses) #:prefix license:)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix build-system)
|
||||
#:use-module (gnu packages)
|
||||
#:use-module (srfi srfi-64))
|
||||
|
||||
(test-begin "import-utils")
|
||||
|
|
@ -98,4 +99,25 @@ (define-module (test-import-utils)
|
|||
(or (package-license (alist->package meta))
|
||||
'license-is-false)))
|
||||
|
||||
(test-equal "alist->package with dependencies"
|
||||
`(("gettext" ,(specification->package "gettext")))
|
||||
(let* ((meta '(("name" . "hello")
|
||||
("version" . "2.10")
|
||||
("source" . (("method" . "url-fetch")
|
||||
("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
||||
("sha256" .
|
||||
(("base32" .
|
||||
"0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
||||
("build-system" . "gnu")
|
||||
("home-page" . "https://gnu.org")
|
||||
("synopsis" . "Say hi")
|
||||
("description" . "This package says hi.")
|
||||
;
|
||||
;; Note: As with Guile-JSON 3.x, JSON arrays are represented
|
||||
;; by vectors.
|
||||
("native-inputs" . #("gettext"))
|
||||
|
||||
("license" . #f))))
|
||||
(package-native-inputs (alist->package meta))))
|
||||
|
||||
(test-end "import-utils")
|
||||
|
|
|
|||
Loading…
Reference in a new issue