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