mirror of
https://codeberg.org/guix/guix.git
synced 2026-09-07 22:32:00 +00:00
Maxim Cournoyer
ae77f49d60
* guix/build/json-utils.scm (&modify-json-preexisting-key-error): New
condition. Export condition predicates.
(modify-json-fields): Raise an error when attempting to inserting a
pre-existing key.
* tests/json-utils.scm ("add-json-fields, preexisting field")
("add-json-fields, preexisting multi-level field"): New tests.
311 lines
10 KiB
Scheme
311 lines
10 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2026 Nicolas Graves <ngraves@ngraves.fr>
|
|
;;; Copyright © 2026 Maxim Cournoyer <maxim@guixotic.coop>
|
|
;;;
|
|
;;; 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 (test-json-utils)
|
|
#:use-module (guix build json-utils)
|
|
#:use-module (guix tests)
|
|
#:use-module (json)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (srfi srfi-64))
|
|
|
|
(define sample-json
|
|
'(("name" . "my-package")
|
|
("version" . "1.0.0")
|
|
("dependencies" . (("foo" . "^1.0.0")
|
|
("bar" . "^2.0.0")))
|
|
("devDependencies" . (("baz" . "^3.0.0")
|
|
("qux" . "^4.0.0")))
|
|
("scripts" . (("build" . "make build")
|
|
("test" . "make test")))))
|
|
|
|
;; Many json-utils procedures use assoc-set! and assoc-remove! which
|
|
;; mutate alist structure in place. Use copy-tree to obtain a fresh
|
|
;; deep copy for each test.
|
|
(define (fresh-sample-json)
|
|
(copy-tree sample-json))
|
|
|
|
(define (package.json)
|
|
"Sample package.json file as a JSON string."
|
|
(call-with-output-string
|
|
(cute scm->json sample-json <> #:pretty #t)))
|
|
|
|
(define (with-atomic-file-replacement/mock _ proc)
|
|
"Mock for with-atomic-file-replacement: reads from package.json procedure,
|
|
captures the written output as a string."
|
|
(call-with-input-string (package.json)
|
|
(lambda (in)
|
|
(call-with-output-string
|
|
(cute proc in <>)))))
|
|
|
|
(define* (modify-json* #:rest all-arguments)
|
|
"Mock modify-json* with input from the package.json procedure."
|
|
(mock ((guix build utils) with-atomic-file-replacement
|
|
with-atomic-file-replacement/mock)
|
|
(json-string->scm (apply modify-json all-arguments)
|
|
#:ordered #t)))
|
|
|
|
(test-begin "json-utils")
|
|
|
|
;;;
|
|
;;; with-atomic-json-file-replacement
|
|
;;;
|
|
|
|
(test-equal "with-atomic-json-file-replacement, modify top-level field"
|
|
"2.0.0"
|
|
(assoc-ref
|
|
(modify-json* (cut assoc-set! <> "version" "2.0.0"))
|
|
"version"))
|
|
|
|
;;;
|
|
;;; delete-json-fields
|
|
;;;
|
|
|
|
(test-assert "delete-json-fields, single top-level field"
|
|
(let ((result ((delete-json-fields '("version")) (fresh-sample-json))))
|
|
(and (not (assoc-ref result "version"))
|
|
(assoc-ref result "name"))))
|
|
|
|
(test-assert "delete-json-fields, multiple top-level fields"
|
|
(let ((result ((delete-json-fields '("version" "name")) (fresh-sample-json))))
|
|
(and (not (assoc-ref result "version"))
|
|
(not (assoc-ref result "name"))
|
|
(assoc-ref result "dependencies"))))
|
|
|
|
(test-assert "delete-json-fields, nested field with dot syntax"
|
|
(let ((result ((delete-json-fields '("dependencies.foo")) (fresh-sample-json))))
|
|
(and (not (assoc-ref (assoc-ref result "dependencies") "foo"))
|
|
(assoc-ref (assoc-ref result "dependencies") "bar"))))
|
|
|
|
(test-assert "delete-json-fields, nested field with list syntax"
|
|
(let ((result ((delete-json-fields '(("dependencies" "bar")))
|
|
(fresh-sample-json))))
|
|
(and (not (assoc-ref (assoc-ref result "dependencies") "bar"))
|
|
(assoc-ref (assoc-ref result "dependencies") "foo"))))
|
|
|
|
(test-assert "delete-json-fields, missing field with strict? #f"
|
|
(let ((result ((delete-json-fields '("nonexistent") #:strict? #f)
|
|
(fresh-sample-json))))
|
|
(assoc-ref result "name")))
|
|
|
|
(test-error "delete-json-fields, missing field with strict? #t raises error"
|
|
&modify-json-missing-key-error
|
|
((delete-json-fields '("nonexistent") #:strict? #t) (fresh-sample-json)))
|
|
|
|
(test-assert "delete-json-fields, missing nested field with strict? #f"
|
|
(let ((result ((delete-json-fields '("dependencies.nonexistent")
|
|
#:strict? #f)
|
|
(fresh-sample-json))))
|
|
(assoc-ref (assoc-ref result "dependencies") "foo")))
|
|
|
|
;;;
|
|
;;; replace-json-fields
|
|
;;;
|
|
|
|
(test-equal "replace-json-fields, single top-level field"
|
|
"new-name"
|
|
(assoc-ref
|
|
((replace-json-fields '(("name" . "new-name"))) (fresh-sample-json))
|
|
"name"))
|
|
|
|
(test-equal "replace-json-fields, nested field with dot syntax"
|
|
"^5.0.0"
|
|
(assoc-ref
|
|
(assoc-ref
|
|
((replace-json-fields '(("dependencies.foo" . "^5.0.0")))
|
|
(fresh-sample-json))
|
|
"dependencies")
|
|
"foo"))
|
|
|
|
(test-equal "replace-json-fields, nested field with list syntax"
|
|
"^6.0.0"
|
|
(assoc-ref
|
|
(assoc-ref
|
|
((replace-json-fields '((("dependencies" "bar") . "^6.0.0")))
|
|
(fresh-sample-json))
|
|
"dependencies")
|
|
"bar"))
|
|
|
|
(test-equal "replace-json-fields, multiple replacements"
|
|
'("new-name" . "2.0.0")
|
|
(let ((result ((replace-json-fields
|
|
'(("name" . "new-name")
|
|
("version" . "2.0.0")))
|
|
(fresh-sample-json))))
|
|
(cons (assoc-ref result "name")
|
|
(assoc-ref result "version"))))
|
|
|
|
(test-error "replace-json-fields, missing field with strict? #t raises error"
|
|
&modify-json-missing-key-error
|
|
((replace-json-fields '(("nonexistent" . "value")) #:strict? #t)
|
|
(fresh-sample-json)))
|
|
|
|
(test-assert "replace-json-fields, missing field with strict? #f"
|
|
(let ((result ((replace-json-fields '(("nonexistent" . "value"))
|
|
#:strict? #f)
|
|
(fresh-sample-json))))
|
|
(equal? (assoc-ref result "name") "my-package")))
|
|
|
|
;;;
|
|
;;; add-json-fields
|
|
;;;
|
|
(test-equal "add-json-fields"
|
|
#("test")
|
|
(assoc-ref (modify-json*
|
|
(add-json-fields '(("exclude" . #("test")))))
|
|
"exclude"))
|
|
|
|
(test-equal "add-json-fields, recursive"
|
|
"^25.9.2"
|
|
(assoc-ref (assoc-ref (modify-json*
|
|
(add-json-fields '(("devDependencies2.@types/node"
|
|
. "^25.9.2"))))
|
|
"devDependencies2")
|
|
"@types/node"))
|
|
|
|
(test-equal "add-json-fields, recursive, partially preexisting"
|
|
"^9.9.9"
|
|
(assoc-ref (assoc-ref (modify-json*
|
|
(add-json-fields '(("devDependencies.@types/dummy"
|
|
. "^9.9.9"))))
|
|
"devDependencies")
|
|
"@types/dummy"))
|
|
|
|
(test-error "add-json-fields, preexisting field"
|
|
&modify-json-preexisting-key-error
|
|
(modify-json* (add-json-fields '(("name" . "duplicate")))))
|
|
|
|
(test-error "add-json-fields, preexisting multi-level field"
|
|
&modify-json-preexisting-key-error
|
|
(modify-json* (add-json-fields '(("devDependencies.qux"
|
|
. "^9.0.0")))))
|
|
|
|
;;;
|
|
;;; modify-json-fields
|
|
;;;
|
|
|
|
(test-equal "modify-json-fields, custom modifier on top-level field"
|
|
"MY-PACKAGE"
|
|
(assoc-ref
|
|
((modify-json-fields '("name")
|
|
(lambda (field data key)
|
|
(assoc-set! data key (string-upcase (assoc-ref data key)))))
|
|
(fresh-sample-json))
|
|
"name"))
|
|
|
|
(test-equal "modify-json-fields, custom modifier on nested field"
|
|
"^1.0.0-patched"
|
|
(assoc-ref
|
|
(assoc-ref
|
|
((modify-json-fields '("dependencies.foo")
|
|
(lambda (field data key)
|
|
(assoc-set! data key
|
|
(string-append (assoc-ref data key) "-patched"))))
|
|
(fresh-sample-json))
|
|
"dependencies")
|
|
"foo"))
|
|
|
|
(test-assert "modify-json-fields, insert? creates missing field"
|
|
(let ((result ((modify-json-fields '("newField")
|
|
(lambda (field data key)
|
|
(assoc-set! data key "inserted"))
|
|
#:insert? #t)
|
|
(fresh-sample-json))))
|
|
(equal? (assoc-ref result "newField") "inserted")))
|
|
|
|
(test-assert "modify-json-fields, insert? creates nested missing fields"
|
|
(let ((result ((modify-json-fields '("newSection.newKey")
|
|
(lambda (field data key)
|
|
(assoc-set! data key "deep-insert"))
|
|
#:insert? #t)
|
|
(fresh-sample-json))))
|
|
(equal? (assoc-ref (assoc-ref result "newSection") "newKey")
|
|
"deep-insert")))
|
|
|
|
(test-assert "modify-json-fields, field-path-mapper"
|
|
(let ((result ((modify-json-fields '(("name" . "REPLACED"))
|
|
(lambda (field data key)
|
|
(assoc-set! data key (cdr field)))
|
|
#:field-path-mapper car)
|
|
(fresh-sample-json))))
|
|
(equal? (assoc-ref result "name") "REPLACED")))
|
|
|
|
(test-error "modify-json-fields, invalid field-path raises error"
|
|
&modify-json-invalid-field-value-error
|
|
((modify-json-fields '(42) (lambda (field data key) data))
|
|
(fresh-sample-json)))
|
|
|
|
(test-equal "modify-json, ordering"
|
|
'(("baz" . "^3.0.0")
|
|
("qux" . "^4.0.0"))
|
|
(assoc-ref (modify-json* (modify-json-fields
|
|
'("devDependencies.qux")
|
|
(lambda (field-path data key)
|
|
data))) ;no-op
|
|
"devDependencies"))
|
|
|
|
;;;
|
|
;;; modify-json (deprecated wrapper)
|
|
;;;
|
|
|
|
(test-equal "modify-json, single modification"
|
|
"modified"
|
|
(assoc-ref
|
|
(modify-json* (cut assoc-set! <> "name" "modified"))
|
|
"name"))
|
|
|
|
(test-equal "modify-json, chained modifications"
|
|
'("chain-name" . "3.0.0")
|
|
(let ((result (modify-json*
|
|
(cut assoc-set! <> "name" "chain-name")
|
|
(cut assoc-set! <> "version" "3.0.0"))))
|
|
(cons (assoc-ref result "name")
|
|
(assoc-ref result "version"))))
|
|
|
|
;;;
|
|
;;; Integration: delete-json-fields and replace-json-fields with modify-json
|
|
;;;
|
|
|
|
(test-equal "modify-json + delete-json-fields integration"
|
|
#f
|
|
(assoc-ref
|
|
(modify-json* (delete-json-fields '("devDependencies")))
|
|
"devDependencies"))
|
|
|
|
(test-equal "modify-json + replace-json-fields integration"
|
|
"^9.0.0"
|
|
(assoc-ref
|
|
(assoc-ref
|
|
(modify-json* (replace-json-fields '(("dependencies.foo" . "^9.0.0"))))
|
|
"dependencies")
|
|
"foo"))
|
|
|
|
(test-equal "modify-json + chained delete and replace integration"
|
|
'(#f . "replaced-name")
|
|
(let ((result (modify-json*
|
|
(delete-json-fields '("devDependencies"))
|
|
(replace-json-fields '(("name" . "replaced-name"))))))
|
|
(cons (assoc-ref result "devDependencies")
|
|
(assoc-ref result "name"))))
|
|
|
|
(test-end "json-utils")
|
|
|
|
;; Local Variables:
|
|
;; eval: (put 'modify-json-fields 'scheme-indent-function 1)
|
|
;; End:
|