blob: c4b49f00a92b28c1ee6b9ebb58c9256cf617dfee (
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
|
;; 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 client-manifest)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc fetch)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-19)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (rdf rdf)
#:use-module (turtle tordf))
(define-public public-oidc-client
'public-oidc-client)
(define-public (all-uris x)
(or (null? x)
(and (string->uri (car x))
(all-uris (cdr x)))))
(define-public (the-client-manifest x)
(if (eq? x public-oidc-client)
public-oidc-client
(let ((client-id (assq-ref x 'client_id))
(redirect-uris (assq-ref x 'redirect_uris)))
(unless (and client-id (string? client-id) (string->uri client-id))
(raise-incorrect-client-id-field client-id))
(unless (and redirect-uris
(vector? redirect-uris)
(all-uris (vector->list redirect-uris)))
(raise-incorrect-redirect-uris-field redirect-uris))
x)))
(define-public (client-manifest? obj)
(false-if-exception
(and (the-client-manifest obj) #t)))
(define-public (make-client-manifest client-id redirect-uris)
(the-client-manifest
`((client_id . ,(uri->string client-id))
(redirect_uris . ,(list->vector
(map uri->string
redirect-uris))))))
(define-public (client-manifest-client-id mf)
(if (eq? mf public-oidc-client)
(string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")
(string->uri (assq-ref (the-client-manifest mf) 'client_id))))
(define (check-redirect mf uris redir)
(if (null? uris)
(raise-unauthorized-redirection-uri mf (string->uri redir))
(or (string=? (car uris) redir)
(check-redirect mf (cdr uris) redir))))
(define-public (client-manifest-check-redirect-uri mf redir)
(unless (uri? redir)
(set! redir (string->uri redir)))
(if (eq? mf public-oidc-client)
#t
(let ((redirect-uris
(assq-ref (the-client-manifest mf) 'redirect_uris)))
(check-redirect (the-client-manifest mf)
(vector->list redirect-uris)
(uri->string redir)))))
(define-public (serve-client-manifest expiration-date mf)
(when (eq? mf public-oidc-client)
(raise-cannot-serve-public-manifest))
(let ((json-object (stubs:scm->json-string
`((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
,@(the-client-manifest mf)))))
(values (build-response #:headers `((content-type application/ld+json)
(expires . ,expiration-date)))
json-object)))
(define*-public (get-client-manifest id
#:key
(http-get http-get))
(unless (uri? id)
(set! id (string->uri id)))
(with-exception-handler
(lambda (error)
(raise-cannot-fetch-client-manifest id error))
(lambda ()
(if (equal? id
(string->uri
"http://www.w3.org/ns/solid/terms#PublicOidcClient"))
public-oidc-client
(receive (response response-body)
(http-get id)
(when (bytevector? response-body)
(set! response-body (utf8->string response-body)))
(let ((mf (the-client-manifest (stubs:json-string->scm response-body))))
(unless (equal? (uri->string (client-manifest-client-id mf))
(uri->string id))
(raise-inconsistent-client-manifest-id
id
(client-manifest-client-id mf)))
mf))))))
|
