Browse Source

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.
gn-latest-20200428
Ludovic Courtès 1 year ago
parent
commit
81c3dc3224
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
22 changed files with 140 additions and 104 deletions
  1. +2
    -2
      configure.ac
  2. +1
    -1
      doc/guix.texi
  3. +2
    -2
      gnu/installer.scm
  4. +12
    -9
      gnu/installer/locale.scm
  5. +1
    -1
      gnu/system/vm.scm
  6. +10
    -9
      guix/docker.scm
  7. +2
    -2
      guix/git-download.scm
  8. +7
    -7
      guix/import/cpan.scm
  9. +3
    -3
      guix/import/crate.scm
  10. +7
    -3
      guix/import/gem.scm
  11. +7
    -6
      guix/import/github.scm
  12. +2
    -9
      guix/import/json.scm
  13. +7
    -6
      guix/import/launchpad.scm
  14. +4
    -4
      guix/import/pypi.scm
  15. +2
    -2
      guix/import/stackage.scm
  16. +6
    -19
      guix/import/utils.scm
  17. +1
    -1
      guix/scripts/import/json.scm
  18. +1
    -1
      guix/scripts/pack.scm
  19. +1
    -1
      guix/self.scm
  20. +19
    -16
      guix/swh.scm
  21. +21
    -0
      m4/guix.m4
  22. +22
    -0
      tests/import-utils.scm

+ 2
- 2
configure.ac View File

@@ -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



+ 1
- 1
doc/guix.texi View File

@@ -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


+ 2
- 2
gnu/installer.scm View File

@@ -69,7 +69,7 @@ version of this file."
(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 @@ selected keymap."
;; 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)


+ 12
- 9
gnu/installer/locale.scm View File

@@ -134,16 +134,18 @@ ISO639-3 and ISO639-5 files."
(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 @@ ISO3166 file."
(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


+ 1
- 1
gnu/system/vm.scm View File

@@ -514,7 +514,7 @@ system."
(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)


+ 10
- 9
guix/docker.scm View File

@@ -62,9 +62,9 @@

(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 @@
`((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.


+ 2
- 2
guix/git-download.scm View File

@@ -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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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))


+ 7
- 7
guix/import/cpan.scm View File

@@ -76,8 +76,8 @@
;; 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 @@
"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 @@ return \"Test-Simple\""
"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))


+ 3
- 3
guix/import/crate.scm View File

@@ -51,7 +51,7 @@
(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 @@
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)


+ 7
- 3
guix/import/gem.scm View File

@@ -40,7 +40,7 @@
(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 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
(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)))))


+ 7
- 6
guix/import/github.scm View File

@@ -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 @@ repository separated by a forward slash, from a string URL of the form

(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 @@ empty list."
'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 @@ the package e.g. 'bedtools2'. Return #f if there is no releases"
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


+ 2
- 9
guix/import/json.scm View File

@@ -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 @@
#: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 @@ the query."
(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))

+ 7
- 6
guix/import/launchpad.scm View File

@@ -87,15 +87,16 @@ for example, 'linuxdcpp'. Return #f if there is no releases."
;; 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)


+ 4
- 4
guix/import/pypi.scm View File

@@ -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 (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 @@ or #f on failure."
(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 @@ or #f if there isn't any."
(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)


+ 2
- 2
guix/import/stackage.scm View File

@@ -60,7 +60,7 @@
(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 (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)))



+ 6
- 19
guix/import/utils.scm View File

@@ -45,7 +45,6 @@
#:use-module (srfi srfi-41)
#:export (factorize-uri

hash-table->alist
flatten
assoc-ref*

@@ -100,21 +99,6 @@ of the string VERSION is replaced by the symbol '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 @@ the expected fields of an <origin> object."
(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


+ 1
- 1
guix/scripts/import/json.scm View File

@@ -93,7 +93,7 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n"))
(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))))
(()


+ 1
- 1
guix/scripts/pack.scm View File

@@ -479,7 +479,7 @@ the image."

(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)


+ 1
- 1
guix/self.scm View File

@@ -50,7 +50,7 @@
(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))


+ 19
- 16
guix/swh.scm View File

@@ -138,16 +138,16 @@ following SPEC, a series of field specifications."
(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 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(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 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(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 @@ FALSE-IF-404? is true, return #f upon 404 responses."
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
- 0
m4/guix.m4 View File

@@ -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],


+ 22
- 0
tests/import-utils.scm View File

@@ -23,6 +23,7 @@
#: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 @@
(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…
Cancel
Save