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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
(define-module (webid-oidc authorization-page-unsafe)
#:use-module (webid-oidc errors)
#:use-module (sxml simple)
#:use-module (web uri)
#:use-module (web response)
#:use-module (ice-9 i18n)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 string-fun))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define (str->sxml str)
(cdadr
(xml->sxml
(string-append "<protect>" str "</protect>"))))
(define (make-page title . body)
(with-output-to-string
(lambda ()
(sxml->xml
`(*TOP*
(*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang ,(G_ "xml-lang|en")))
(head
(title ,title))
(body
,@body)))))))
(define-public (authorization-page credential-invalid?
client-id post-uri)
(when (uri? client-id)
(set! client-id (uri->string client-id)))
(when (string? post-uri)
(set! post-uri (string->uri post-uri)))
(values (build-response
#:headers `((content-type application/xhtml+xml)))
(make-page
(G_ "page-title|Authorization")
(if (equal?
(string->uri client-id)
(string->uri
"http://www.w3.org/ns/solid/terms#PublicOidcClient"))
`(h1 ,@(str->sxml (G_ "Authorize this anonymous application?")))
`(h1 ,@(str->sxml (format #f (G_ "Authorize <a href=~s>~a</a>?")
client-id client-id))))
`(p ,@(str->sxml (G_ "Do you want to authorize this application to represent you?")))
`(form (@ (action ,(uri->string post-uri))
(method "POST"))
(div
(label (@ (for "password")
,@(if credential-invalid?
'((class "authz-page-credential-error"))
'()))
,@(str->sxml
(if credential-invalid?
(G_ "Please retry your password:")
(G_ "Please enter your password:"))))
(input (@ (type "password")
(name "password")
(id "password"))))
(input (@ (type "submit")
(value ,(G_ "Allow"))))))))
(define (bad-request . body)
(values (build-response #:code 400
#:reason-phrase "Bad Request"
#:headers '((content-type application/xhtml+xml)))
(apply make-page (G_ "Bad request") body)))
(define-public (error-no-client-id)
(bad-request
`(p ,@(str->sxml
(G_ "The application did not set the <emph>client_id</emph> parameter.")))))
(define-public (error-no-redirect-uri)
(bad-request
`(p ,@(str->sxml
(G_ "The application did not set the <emph>redirect_uri</emph> parameter.")))))
(define (wrap-error err)
(if (record? err)
(let* ((type (record-type-descriptor err))
(get
(lambda (slot)
((record-accessor type slot) err)))
(recurse
(lambda (err)
(wrap-error err))))
(case (record-type-name type)
((¬-base64)
`((li ,(format #f (G_ "the value ~s is not a base64 string.")
(get 'value)))))
((¬-json)
`((li ,(format #f (G_ "the following value is not JSON:"))
(pre ,(get 'value)))))
((¬-turtle)
`((li ,(format #f (G_ "the following value is not Turtle:"))
(pre ,(get 'value)))))
((&response-failed-unexpectedly)
`((li ,(format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s.")
(get 'response-code) (get 'response-reason-phrase)))))
((&unexpected-header-value)
`((li ,(let ((value (get 'value)))
(if value
(format #f (G_ "the header ~a should not have the value ~s.\n")
(get 'header) value)
(format #f (G_ "the header ~a should be present.")
(get 'header)))))))
((&unexpected-response)
(cons
`(li ,(format #f (G_ "the server response wasn’t expected:"))
(pre ,(call-with-output-string
(lambda (port)
(write-response (get 'response) port)))))
(recurse (get 'cause))))
((&incorrect-client-id-field)
(let ((value (get 'value)))
`((li
,(if value
(format #f (G_ "the client_id field is incorrect: ~s") value)
(G_ "the client_id field is missing"))))))
((&incorrect-redirect-uris-field)
(let ((value (get 'value)))
`((li
,(if value
(format #f (G_ "the redirect_uris field is incorrect: ~s") value)
(G_ "the redirect_uris field is missing"))))))
((&cannot-fetch-linked-data)
(cons
`(li ,(format #f (G_ "I could not fetch a RDF graph at ~a;") (uri->string (get 'uri))))
(recurse (get 'cause))))
((¬-a-client-manifest)
(cons
`(li ,(format #f (G_ "this is not a client manifest:"))
(pre ,(format #f "~s" (get 'value))))
(recurse (get 'cause))))
((&unauthorized-redirection-uri)
(cons
`(li ,(format #f (G_ "the manifest does not authorize redirection URI ~a:")
(uri->string (get 'uri)))
(pre ,(format #f "~s" (get 'manifest))))
(recurse (get 'cause))))
((&inconsistent-client-manifest-id)
`((li ,(format #f (G_ "the client manifest at ~a is advertised for ~a;")
(uri->string (get 'id))
(uri->string (get 'advertised-id))))))
((&cannot-fetch-client-manifest)
(cons
`(li ,(format #f (G_ "I could not fetch the client manifest of ~a;")
(uri->string (get 'id))))
(recurse (get 'cause))))
((¬-an-authorization-code-payload)
(cons
`(li ,(format #f (G_ "I could not issue an authorization code for you;")))
(recurse (get 'cause))))
(else
(raise-exception err))))
(throw err)))
(define-public (error-application error)
(bad-request
`(p ,(G_ "The application you are trying to authorize behaved unexpectedly. Here is the explanation of the error:")
(ol ,@(wrap-error error)))))
(define-public (redirection client-id uri)
(values (build-response
#:code 302
#:headers `((location . ,uri)
(content-type application/xhtml+xml)))
(make-page
(G_ "Redirecting...")
`(h1 "Authorization granted, you are being redirected")
`(p ,@(str->sxml
(format
#f
(G_ "<a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.")
(uri->string client-id)
(uri->string client-id)))))))
|
