Add webfinger generation support and tests

Julien LepillerSun Oct 04 02:17:46+0200 2020

e885abb

Add webfinger generation support and tests

guix.scm

4848 
   `(#:make-flags '("SCHEMA_ORG_FILE=schema.org/schema.jsonld")))
4949 
  (inputs
5050 
   `(("guile" ,guile-3.0)
51-
     ("guile-json" ,guile3.0-json)
51+
     ("guile-json" ,guile-json-4)
5252 
     ("guile-jsonld" ,guile-jsonld)
53-
     ("guile-gcrypt" ,guile3.0-gcrypt)))
53+
     ("guile-gcrypt" ,guile-gcrypt)))
5454 
  (native-inputs
5555 
   `(("automake" ,automake)
5656 
     ("autoconf" ,autoconf)

tests/webfinger.scm unknown status 1

1+
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2+
;;;;
3+
;;;; This library is free software; you can redistribute it and/or
4+
;;;; modify it under the terms of the GNU Lesser General Public
5+
;;;; License as published by the Free Software Foundation; either
6+
;;;; version 3 of the License, or (at your option) any later version.
7+
;;;;
8+
;;;; This library is distributed in the hope that it will be useful,
9+
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10+
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11+
;;;; Lesser General Public License for more details.
12+
;;;;
13+
;;;; You should have received a copy of the GNU Lesser General Public
14+
;;;; License along with this library; if not, write to the Free Software
15+
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16+
;;;;
17+
18+
(define-module (tests webfinger)
19+
  #:use-module (ice-9 format)
20+
  #:use-module (json)
21+
  #:use-module (rnrs bytevectors)
22+
  #:use-module (srfi srfi-64)
23+
  #:use-module (webfinger webfinger))
24+
25+
(test-begin "webfinger")
26+
27+
(define simple-record-scm
28+
  '(("subject" . "acct:carol@example.com")
29+
    ("links" . #((("rel" . "http://openid.net/specs/connect/1.0/issuer")
30+
                  ("href" . "https://openid.example.com"))))))
31+
(define simple-record
32+
  (make-jrd-record
33+
    "acct:carol@example.com"
34+
    '()
35+
    #f
36+
    (list
37+
      (make-link-record
38+
        "http://openid.net/specs/connect/1.0/issuer"
39+
        #f
40+
        "https://openid.example.com"
41+
        #f
42+
        #f))))
43+
44+
(test-assert "simple example decode"
45+
  (let ((converted-simple-record (json->jrd-record simple-record-scm)))
46+
    (if (equal? converted-simple-record simple-record)
47+
        #t
48+
        (pk 'fail converted-simple-record #f))))
49+
50+
(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)
54+
        #t
55+
        (pk 'fail converted-simple-record-scm #f))))
56+
57+
(test-end "webfinger")
webfinger/webfinger.scm
2727 
            jrd-record-aliases
2828 
            jrd-record-properties
2929 
            jrd-record-links
30+
            jrd-record->json
31+
            json->jrd-record
3032 
3133 
            make-link-record
3234 
            link-record?
…
3537 
            link-record-href
3638 
            link-record-titles
3739 
            link-record-properties
40+
            link-record->json
41+
            json->link-record
3842 
3943 
            webfinger-query
40-
            find-actor-object))
44+
            find-actor-object
45+
            jrd->string))
4146 
42-
(define-record-type <jrd-record>
43-
  (make-jrd-record subject aliases properties links)
44-
  jrd-record?
45-
  (subject    jrd-record-subject) ; string
46-
  (aliases    jrd-record-aliases) ; string list
47-
  (properties jrd-record-properties) ; alist whose keys and values are strings
48-
  (links      jrd-record-links)) ; list of links
49-
50-
(define-record-type <link-record>
51-
  (make-link-record rel type href titles properties)
52-
  link-record?
47+
(define-json-mapping <link-record> make-link-record link-record?
48+
  json->link-record <=> link-record->json
5349 
  (rel        link-record-rel) ; string
5450 
  (type       link-record-type) ; string
5551 
  (href       link-record-href) ; string
5652 
  (titles     link-record-titles) ; alist whose keys are languages or "und" and values ar strings
5753 
  (properties link-record-properties)) ; alist whose keys and values are strings
5854 
55+
(define-json-mapping <jrd-record> make-jrd-record jrd-record?
56+
  json->jrd-record <=> jrd-record->json
57+
  (subject    jrd-record-subject) ; string
58+
  (aliases    jrd-record-aliases "aliases" ; string list
59+
              (lambda (val)
60+
                (if val (array->list val) '()))
61+
              (lambda (val) (list->array 1 val)))
62+
  (properties jrd-record-properties) ; alist whose keys and values are strings
63+
  (links      jrd-record-links "links" ; list of links
64+
              (lambda (val)
65+
                (if val (map json->link-record (array->list val)) '()))
66+
              (lambda (val) (list->array 1 (map link-record->json val)))))
67+
5968 
(define (download-json uri)
6069 
  (json-string->scm
6170 
    (call-with-values
…
8291 
                'https
8392 
                #:host (uri-host uri)
8493 
                #:path "/.well-known/webfinger"
85-
                #:query query))
86-
         (json (download-json uri)))
87-
    (let ((subject (assoc-ref json "subject"))
88-
          (aliases (assoc-ref json "aliases"))
89-
          (properties (assoc-ref json "properties"))
90-
          (links (assoc-ref json "links")))
91-
    (make-jrd-record
92-
      subject
93-
      (if aliases (array->list aliases) '())
94-
      (or properties '())
95-
      (if links
96-
          (map
97-
            (lambda (link)
98-
              (make-link-record
99-
                (assoc-ref link "rel")
100-
                (assoc-ref link "type")
101-
                (assoc-ref link "href")
102-
                (assoc-ref link "titles")
103-
                (assoc-ref link "properties")))
104-
            (array->list links))
105-
          '())))))
94+
                #:query query)))
95+
    (json->jrd-record (download-json uri))))
10696 
10797 
(define (find-actor-object user server)
10898 
  "Find the actor object of @var{user} on @var{server}.  This uses the webfinger
…
118108 
             (lambda (link)
119109 
               (equal? (link-record-type link) "application/activity+json"))
120110 
             links)))))
111+
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)) '()))))