blob: 43eb707dad47771be564efe47271b6d95b8c0cee (
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program 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 Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (webid-oidc jws)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 receive))
(define-public (the-jws-header x)
(with-exception-handler
(lambda (cause)
(raise-not-a-jws-header x cause))
(lambda ()
(let ((alg (assq-ref x 'alg)))
(unless alg
(raise-missing-alist-key x 'alg))
(unless (string? alg)
(raise-unsupported-alg alg))
(case (string->symbol alg)
((HS256 HS384 HS512 RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512)
x)
(else
(raise-unsupported-alg (string->symbol alg))))))))
(define-public (the-jws-payload x)
(with-exception-handler
(lambda (cause)
(raise-not-a-jws-payload x cause))
(lambda ()
(unless (list? x)
(scm-error 'wrong-type-arg "the-jws-payload" "expected a list" '() (list x)))
x)))
(define-public (the-jws x)
(with-exception-handler
(lambda (cause)
(raise-not-a-jws x cause))
(lambda ()
(unless (pair? x)
(scm-error 'wrong-type-arg "the-jws" "expected a pair" '() (list x)))
(cons (the-jws-header (car x))
(the-jws-payload (cdr x))))))
(define-public (jws-header? x)
(false-if-exception
(and (the-jws-header x) #t)))
(define-public (jws-payload? x)
(false-if-exception
(and (the-jws-payload x) #t)))
(define-public (jws? x)
(false-if-exception
(and (the-jws x) #t)))
(define-public (make-jws header payload)
(the-jws (cons (the-jws-header header)
(the-jws-payload payload))))
(define-public (jws-header jws)
(car (the-jws jws)))
(define-public (jws-payload jws)
(cdr (the-jws jws)))
(define-public (jws-alg jws)
(if (jws? jws)
(jws-alg (jws-header jws))
(string->symbol (assq-ref (the-jws-header jws) 'alg))))
(define (split-in-3-parts string separator)
(let ((parts (list->vector (string-split string separator))))
(unless (eqv? (vector-length parts) 3)
(raise-not-in-3-parts string separator))
(values (vector-ref parts 0) (vector-ref parts 1) (vector-ref parts 2))))
(define (base64-decode-json str)
(with-exception-handler
(lambda (error)
(cond
(((record-predicate ¬-base64) error)
(raise-exception error))
(((record-predicate ¬-json) error)
(raise-exception error))
(else
;; From utf8->string
(raise-not-base64 str error))))
(lambda ()
(stubs:json-string->scm (utf8->string (stubs:base64-decode str))))))
(define (parse str verify)
(receive (header payload signature)
(split-in-3-parts str #\.)
(let ((base (string-append header "." payload))
(header (base64-decode-json header))
(payload (base64-decode-json payload)))
(let ((ret (make-jws header payload)))
(verify ret base signature)
ret))))
(define (verify-any alg keys payload signature)
(define (aux candidates)
(if (null? keys)
(raise-no-matching-key keys alg payload signature)
(let ((next-ok
(with-exception-handler
(lambda (error)
#f)
(lambda ()
(stubs:verify alg (car candidates) payload signature)
#t)
#:unwind? #t
#:unwind-for-type &invalid-signature)))
(or next-ok
(aux (cdr candidates))))))
(aux keys))
(define-public (jws-decode str lookup-keys)
(with-exception-handler
(lambda (error)
(raise-cannot-decode-jws str error))
(lambda ()
(parse str
(lambda (jws payload signature)
(let ((keys (lookup-keys jws)))
(let ((keys (cond ((jwk? keys) (list keys))
((jwks? keys) (jwks-keys keys))
(else keys))))
(verify-any (jws-alg jws) keys payload signature))))))))
(define-public (jws-encode jws key)
(with-exception-handler
(lambda (error)
(raise-cannot-encode-jws jws key error))
(lambda ()
(let ((header (jws-header jws))
(payload (jws-payload jws)))
(let ((header (stubs:scm->json-string header))
(payload (stubs:scm->json-string payload)))
(let ((header (stubs:base64-encode header))
(payload (stubs:base64-encode payload)))
(let ((payload (string-append header "." payload)))
(let ((signature (stubs:sign (jws-alg jws) key payload)))
(string-append payload "." signature)))))))))
|
