Use fixed guile-json for optional mapping

Julien LepillerSun Oct 04 16:40:57+0200 2020

ff5b87e

Use fixed guile-json for optional mapping

Makefile.am

2727 
      $(top_srcdir)/build-aux/test-driver.scm
2828 
2929 
TEST_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(top_srcdir)/tap-driver.sh --ignore-exit
30-
TESTS = tests/asn1.scm
30+
TESTS = tests/asn1.scm \
31+
  tests/webfinger.scm
3132 
EXTRA_DIST += $(TESTS)
3233 
3334 
schema.org/vocabulary.scm: schema.org/generate-vocabulary.scm $(SCHEMA_ORG_FILE)
guix.scm
3030 
  (gnu packages texinfo)
3131 
  (gnu packages tls))
3232 
33+
(define my-guile-json
34+
  (package
35+
    (inherit guile-json-4)
36+
    (source (origin
37+
              (method git-fetch)
38+
              (uri (git-reference
39+
                     (url "https://github.com/aconchillo/guile-json")
40+
                     (commit "2e9512b43e31bb697efd359509e986321a903f69")))
41+
              (file-name (git-file-name "guile-json"
42+
                                        (string-append
43+
                                          (package-version guile-json-4)
44+
                                          "-2e9512b")))
45+
              (sha256
46+
               (base32
47+
                "1al7pa9726fsj4hki0zqzgknn3v2kn3d01wp6fmkdc3cwpyamanc"))))
48+
    (native-inputs
49+
     `(("autoconf" ,autoconf)
50+
       ("automake" ,automake)
51+
       ("pkg-config" ,pkg-config)
52+
       ,@(package-native-inputs guile-json-4)))))
53+
3354 
(package
3455 
  (name "guile-fediverse")
3556 
  (version "0.1.0")
…
4869 
   `(#:make-flags '("SCHEMA_ORG_FILE=schema.org/schema.jsonld")))
4970 
  (inputs
5071 
   `(("guile" ,guile-3.0)
51-
     ("guile-json" ,guile-json-4)
72+
     ("guile-json" ,my-guile-json)
5273 
     ("guile-jsonld" ,guile-jsonld)
5374 
     ("guile-gcrypt" ,guile-gcrypt)))
5475 
  (native-inputs
tests/webfinger.scm
1717 
1818 
(define-module (tests webfinger)
1919 
  #:use-module (ice-9 format)
20+
  #:use-module (ice-9 match)
2021 
  #:use-module (json)
2122 
  #:use-module (rnrs bytevectors)
23+
  #:use-module (srfi srfi-1)
2224 
  #:use-module (srfi srfi-64)
2325 
  #:use-module (webfinger webfinger))
2426 
2527 
(test-begin "webfinger")
2628 
29+
(define (json-has-key? json key)
30+
  (match json
31+
    (((k . v) json ...)
32+
     (or (equal? key k) (json-has-key? json key)))
33+
    (_ #f)))
34+
35+
(define (alist-include? j1 j2)
36+
  (fold
37+
    (lambda (elem acc)
38+
      (if acc
39+
          (match elem
40+
            ((key . value)
41+
             (and
42+
               (json-has-key? j2 key)
43+
               (json-equal? value (assoc-ref j2 key))))
44+
            (_ #f))
45+
          #f))
46+
    #t
47+
    j1))
48+
49+
(define (json-equal? j1 j2)
50+
  (cond
51+
    ((list? j1)
52+
     (and (list? j2)
53+
          (alist-include? j1 j2)
54+
          (alist-include? j2 j1)))
55+
    ((string? j1)
56+
     (equal? j1 j2))
57+
    ((array? j1)
58+
     (let loop ((j1 j1) (j2 j2))
59+
       (match (cons j1 j2)
60+
         ((#() . #())
61+
          #t)
62+
         ((#(v1 j1 ...) . #(v2 j2 ...))
63+
          (and (json-equal? v1 v2)
64+
               (loop `#(,@j1) `#(,@j2))))
65+
         (_ #f))))
66+
    (else (equal? j1 j2))))
67+
2768 
(define simple-record-scm
2869 
  '(("subject" . "acct:carol@example.com")
2970 
    ("links" . #((("rel" . "http://openid.net/specs/connect/1.0/issuer")
…
3273 
  (make-jrd-record
3374 
    "acct:carol@example.com"
3475 
    '()
35-
    #f
76+
    *unspecified*
3677 
    (list
3778 
      (make-link-record
3879 
        "http://openid.net/specs/connect/1.0/issuer"
39-
        #f
80+
        *unspecified*
4081 
        "https://openid.example.com"
41-
        #f
42-
        #f))))
82+
        *unspecified*
83+
        *unspecified*))))
84+
85+
(test-assert "json-equality"
86+
  (and (json-equal? #t #t)
87+
       (json-equal? #f #f)
88+
       (json-equal? "abc" "abc")
89+
       (not (json-equal? "abc" "cba"))
90+
       (json-equal? #() #())
91+
       (json-equal? #(1 2) #(1 2))
92+
       (not (json-equal? #(1 2) #(2 1)))
93+
       (json-equal? '(("a" . 1) ("b" . 2))
94+
                    '(("a" . 1) ("b" . 2)))
95+
       (json-equal? '(("a" . 1) ("b" . 2))
96+
                    '(("b" . 2) ("a" . 1)))))
4397 
4498 
(test-assert "simple example decode"
4599 
  (let ((converted-simple-record (json->jrd-record simple-record-scm)))
…
48102 
        (pk 'fail converted-simple-record #f))))
49103 
50104 
(test-assert "simple example encode"
51-
  (let ((converted-simple-record-scm (jrd->string simple-record)))
52-
    (if (equal? (scm->json-string simple-record-scm)
53-
                converted-simple-record-scm)
105+
  (let ((converted-simple-record-scm (jrd-record->json simple-record)))
106+
    (if (json-equal? simple-record-scm
107+
                     (json-string->scm converted-simple-record-scm))
54108 
        #t
55-
        (pk 'fail converted-simple-record-scm #f))))
109+
        (pk 'fail converted-simple-record-scm
110+
            (scm->json-string simple-record-scm) #f))))
56111 
57112 
(test-end "webfinger")
webfinger/webfinger.scm
5858 
  (aliases    jrd-record-aliases "aliases" ; string list
5959 
              (lambda (val)
6060 
                (if val (array->list val) '()))
61-
              (lambda (val) (list->array 1 val)))
61+
              (lambda (val)
62+
                (if (null? val) *unspecified* (list->array 1 val))))
6263 
  (properties jrd-record-properties) ; alist whose keys and values are strings
6364 
  (links      jrd-record-links "links" ; list of links
6465 
              (lambda (val)
6566 
                (if val (map json->link-record (array->list val)) '()))
66-
              (lambda (val) (list->array 1 (map link-record->json val)))))
67+
              (lambda (val) (list->array 1 (map (lambda (v) (json-string->scm (link-record->json v))) val)))))
6768 
6869 
(define (download-json uri)
6970 
  (json-string->scm
…
109110 
               (equal? (link-record-type link) "application/activity+json"))
110111 
             links)))))
111112 
112-
(define (jrd->string jrd)
113-
  (scm->json-string
114-
    (let ((subject (jrd-record-subject jrd))
115-
          (aliases (jrd-record-aliases jrd))
116-
          (properties (jrd-record-properties jrd))
117-
          (links (jrd-record-links jrd)))
118-
    `(("subject" . ,subject)
119-
      ,@(if (and aliases (not (null? aliases)))
120-
            `(("aliases" . ,(list->array 1 aliases)))
121-
            '())
122-
      ,@(if (and properties (not (null? properties)))
123-
            `(("properties" . ,properties))
124-
            '())
125-
      ("links" . ,(list->array 1 (map link->scm links)))))))
126-
127-
(define (link->scm link)
128-
  (let ((rel (link-record-rel link))
129-
        (type (link-record-type link))
130-
        (href (link-record-href link))
131-
        (titles (link-record-titles link))
132-
        (properties (link-record-properties link)))
133-
    `(("rel" . ,rel)
134-
      ,@(if type `(("href" . ,href)) '())
135-
      ("href" . ,href)
136-
      ,@(if type `(("titles" . ,titles)) '())
137-
      ,@(if type `(("properties" . ,properties)) '()))))
113+
(define jrd->string jrd-record->json)