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
|
;; disfluid, 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 oidc-id-token)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc jws)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc web-i18n)
#:use-module (webid-oidc serializable)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (web uri)
#:use-module (ice-9 optargs)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-19)
#:use-module (oop goops)
#:duplicates (merge-generics)
#:declarative? #t
#:re-export
(
alg iat iss nonce
token->jwt
decode
encode
issue
)
#:export
(
&invalid-id-token
make-invalid-id-token
invalid-id-token?
<id-token> webid sub aud
))
(define-exception-type
&invalid-id-token
&external-error
make-invalid-id-token
invalid-id-token?)
(define-class <id-token> (<single-use-token> <oidc-token>)
(webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string)
(sub #:init-keyword #:sub #:accessor sub)
(aud #:init-keyword #:aud #:accessor aud #:->sxml uri->string)
#:metaclass <plugin-class>
#:module-name '(webid-oidc oidc-id-token))
(define-method (equal? (x <id-token>) (y <id-token>))
(and (equal? (alg x) (alg y))
(equal? (iat x) (iat y))
(equal? ((@ (webid-oidc jws) exp) x) ((@ (webid-oidc jws) exp) y))
(equal? (nonce x) (nonce y))
(equal? (iss x) (iss y))))
(define-method (initialize (token <id-token>) initargs)
(with-exception-handler
(lambda (error)
(raise-exception
(make-exception
(make-invalid-id-token)
(make-exception-with-message
(if (exception-with-message? error)
(format #f (G_ "invalid OIDC ID token: ~a")
(exception-message error))
(G_ "invalid OIDC id token")))
error)))
(lambda ()
(next-method)
(let-keywords
initargs #t
((webid #f)
(sub #f)
(aud #f)
(jwt-header #f)
(jwt-payload #f))
(let do-initialize ((webid webid)
(sub sub)
(aud aud)
(jwt-header jwt-header)
(jwt-payload jwt-payload))
(cond
((string? webid)
(do-initialize (string->uri webid) sub aud jwt-header jwt-payload))
((and (not sub) (uri? webid))
(do-initialize webid (uri->string webid) aud jwt-header jwt-payload))
((string? aud)
(do-initialize webid sub (string->uri aud) jwt-header jwt-payload))
((and webid sub)
(unless (uri? webid)
(scm-error 'wrong-type-arg "make"
(G_ "#:webid should be an URI")
'()
(list webid)))
(unless (string? sub)
(scm-error 'wrong-type-arg "make"
(G_ "#:sub should be a string")
'()
(list sub)))
(unless (uri? aud)
(scm-error 'wrong-type-arg "make"
(G_ "#:aud should be a string")
'()
(list aud)))
(slot-set! token 'webid webid)
(slot-set! token 'sub sub)
(slot-set! token 'aud aud))
((and jwt-header jwt-payload)
(do-initialize (assq-ref jwt-payload 'webid)
(assq-ref jwt-payload 'sub)
(assq-ref jwt-payload 'aud)
#f #f))
(else
(raise-exception
(make-exception
(make-invalid-jws)
(make-exception-with-message
(G_ "when making an ID token either its required fields (#:alg, #:webid, #:iss, #:sub, #:aud, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
(define-method (token->jwt (token <id-token>))
(receive (base-header base-payload)
(next-method)
(values
base-header
`((webid . ,(uri->string (webid token)))
(sub . ,(sub token))
(aud . ,(uri->string (aud token)))
,@base-payload))))
|
