blob: 58fe356f3ea864f9d0a58a5bc3bb40fe979567c5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
(define-module (webid-oidc stubs)
#:use-module (webid-oidc config)
#:use-module (webid-oidc errors)
#:use-module (json))
(load-extension
(format #f "~a/libwebidoidc" libdir)
"init_webidoidc")
(define (fix-base64-decode data)
(catch 'base64-decoding-error
(lambda ()
(base64-decode data))
(lambda error
(raise-not-base64 data error))))
(define (fix-generate-key . args)
(catch 'unsupported-crv
(lambda ()
(apply generate-key args))
(lambda (error)
(raise-unsupported-crv (cadr error)))))
(define (fix-kty key)
(catch 'unsupported-crv
(lambda ()
(let ((ret (kty key)))
(unless ret
(raise-not-a-jwk key #f))
ret))
(lambda error
(raise-unsupported-crv (cadr error)))))
(define (fix-hash alg payload)
(catch 'unsupported-alg
(lambda ()
(hash alg payload))
(lambda error
(raise-unsupported-alg (cadr error)))))
(export
base64-encode
(fix-base64-decode . base64-decode)
random
random-init!
(fix-generate-key . generate-key)
(fix-kty . kty)
strip-key
(fix-hash . hash)
jkt)
;; json reader from guile-json will not behave consistently with
;; SRFI-180 with objects: keys will be mapped to strings, not
;; symbols. So we fix alist keys to be symbols.
(define-public (fix-alists data)
(define (fix-an-alist rest alist)
(if (null? alist)
(reverse rest)
(let ((k/v (car alist))
(tail (cdr alist)))
(let ((key (car k/v))
(value (cdr k/v)))
(fix-an-alist
(acons (string->symbol key)
(fix-alists value)
rest)
tail)))))
(define (fix-a-vector vec)
(list->vector
(map fix-alists
(vector->list vec))))
(cond
((list? data)
(fix-an-alist '() data))
((vector? data)
(fix-a-vector data))
(else data)))
(define (fixed:json-string->scm str)
(with-exception-handler
(lambda (err)
(raise-not-json str err))
(lambda ()
(fix-alists (json-string->scm str)))))
(export (fixed:json-string->scm . json-string->scm))
(define (fixed:json->scm port)
(with-exception-handler
(lambda (err)
(raise-not-json "(input)" err))
(lambda ()
(fix-alists (json->scm port)))))
(export (fixed:json->scm . json->scm))
(define fixed:scm->json-string scm->json-string)
(export (fixed:scm->json-string . scm->json-string))
(define fixed:scm->json scm->json)
(export (fixed:scm->json . scm->json))
|
