blob: 54c098a26660e6c0373312728dcd583a4a71d081 (
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
|
(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 (turtle-escape str)
(define (folder c other)
(if (or (eq? c #\\) (eq? c #\"))
(cons* c #\\ other)
(cons c other)))
(list->string (reverse (string-fold folder '() str))))
(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 (the-client-manifest mf)))
(id (uri->string (client-manifest-client-id (the-client-manifest mf)))))
(let ((resource (string-append "
@prefix solid: <http://www.w3.org/ns/solid/terms#> .
<" id "> solid:oidcRegistration \"\"\"
" (turtle-escape json-object) "
\"\"\" .
")))
(values (build-response #:headers `((content-type text/turtle)
(expires . ,expiration-date)))
resource))))
(define (find-registration id graph)
(cond ((null? graph)
(raise-no-client-manifest-registration (string->uri id)))
((and (string=? (rdf-triple-predicate (car graph))
"http://www.w3.org/ns/solid/terms#oidcRegistration")
(string? (rdf-triple-subject (car graph)))
(string=? (rdf-triple-subject (car graph)) id)
(rdf-literal? (rdf-triple-object (car graph)))
(string=? (rdf-literal-type (rdf-triple-object (car graph)))
"http://www.w3.org/2001/XMLSchema#string"))
(let ((object (rdf-triple-object (car graph))))
(let ((ret (stubs:json-string->scm (rdf-literal-lexical-form object))))
(if (client-manifest? ret)
(begin
(unless (equal? (uri->string (client-manifest-client-id ret))
id)
(raise-inconsistent-client-manifest-id (string->uri id)
(client-manifest-client-id ret)))
ret)
(find-registration id (cdr graph))))))
(else (find-registration id (cdr graph)))))
(define*-public (get-client-manifest id
#:key
(http-get http-get))
(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
(let ((graph (fetch id #:http-get http-get)))
(find-registration (uri->string id) graph))))))
|
