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
160
161
162
163
164
|
;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 access-token)
#:use-module (webid-oidc jws)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc jwk)
#: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 match)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 receive)
#:use-module (oop goops)
#:declarative? #t
#:re-export
(
alg iat exp iss
token->jwt
decode
encode
issue
)
#:export
(
&invalid-access-token
make-invalid-access-token
invalid-access-token?
<access-token> webid aud client-id cnf/jkt
))
(define-exception-type
&invalid-access-token
&external-error
make-invalid-access-token
invalid-access-token?)
(define-class <access-token> (<time-bound-token> <oidc-token>)
(webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string)
(aud #:init-keyword #:aud #:accessor aud)
(client-id #:init-keyword #:client-id #:accessor client-id #:->sxml uri->string)
(cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt)
#:module-name '(webid-oidc access-token))
(define-method (initialize (token <access-token>) initargs)
(with-exception-handler
(lambda (error)
(raise-exception
(make-exception
(make-invalid-access-token)
(make-exception-with-message
(if (exception-with-message? error)
(format #f (G_ "invalid access token: ~a")
(exception-message error))
(G_ "invalid access token")))
error)))
(lambda ()
(next-method)
(let-keywords
initargs #t
((webid #f)
(aud "solid")
(client-id #f)
(cnf/jkt #f)
(client-key #f)
(jwt-header #f)
(jwt-payload #f))
(let do-initialize ((webid webid)
(aud aud)
(client-id client-id)
(cnf/jkt cnf/jkt)
(client-key client-key)
(jwt-header jwt-header)
(jwt-payload jwt-payload))
(cond
((string? webid)
(do-initialize (string->uri webid)
aud
client-id
cnf/jkt
client-key
jwt-header
jwt-payload))
((string? client-id)
(do-initialize webid
aud
(string->uri client-id)
cnf/jkt
client-key
jwt-header
jwt-payload))
((and (not cnf/jkt) client-key)
(do-initialize webid aud client-id (jkt client-key) #f jwt-header jwt-payload))
((and webid client-id cnf/jkt)
(unless (uri? webid)
(scm-error 'wrong-type-arg "make"
(G_ "#:webid should be an URI")
'()
(list webid)))
(unless (uri? client-id)
(scm-error 'wrong-type-arg "make"
(G_ "#:client-id should be an URI")
'()
(list client-id)))
(unless (string? cnf/jkt)
(scm-error 'wrong-type-arg "make"
(G_ "#:cnf/jkt should be a string")
'()
(list cnf/jkt)))
(unless (equal? aud "solid")
(scm-error 'wrong-type-arg "make"
(G_ "#:aud should be exactly \"solid\"")
'()
(list aud)))
(slot-set! token 'webid webid)
(slot-set! token 'aud aud)
(slot-set! token 'client-id client-id)
(slot-set! token 'cnf/jkt cnf/jkt))
((and jwt-header jwt-payload)
(do-initialize (assq-ref jwt-payload 'webid)
(assq-ref jwt-payload 'aud)
(assq-ref jwt-payload 'client_id)
(assq-ref (assq-ref jwt-payload 'cnf) 'jkt)
#f #f #f))
(else
(raise-exception
(make-exception
(make-invalid-jws)
(make-exception-with-message
(G_ "when making an access token either its required fields (#:alg, #:webid, #:iss, #:aud, #:client-id, #:cnf/jkt, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
(define-method (token->jwt (token <access-token>))
(receive (base-header base-payload)
(next-method)
(values
base-header
`((webid . ,(uri->string (webid token)))
(iss . ,(uri->string (iss token)))
(aud . ,(aud token))
(client_id . ,(uri->string (client-id token)))
(cnf . ((jkt . ,(cnf/jkt token))))
(iat . ,(time-second (date->time-utc (iat token))))
(exp . ,(time-second (date->time-utc (exp token))))
,@base-payload))))
|
