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
|
;; 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 server endpoint authentication)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc access-token)
#:use-module (webid-oidc dpop-proof)
#:use-module (webid-oidc provider-confirmation)
#:use-module (webid-oidc server endpoint)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web server)
#:use-module (web client)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (webid-oidc web-i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (sxml simple)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (oop goops)
#:duplicates (merge-generics)
#:declarative? #t
#:export
(
<authenticator>
backend
server-uri
))
(define-class <authenticator> (<endpoint>)
(backend #:init-keyword #:backend #:getter backend)
(server-uri #:init-keyword #:server-uri #:getter server-uri))
(define-method (initialize (endpoint <authenticator>) initargs)
(next-method)
(let-keywords
initargs #t
((backend #f)
(server-uri #f))
(unless (is-a? backend <endpoint>)
(scm-error 'wrong-type-arg "make <authenticator>"
(G_ "#:backend should be an endpoint")
'()
(list backend)))
(match server-uri
((? string? (= string->uri (? uri? the-server-uri)))
(set! server-uri the-server-uri)
(slot-set! endpoint 'server-uri the-server-uri))
(else #t))
(unless (and server-uri (uri? server-uri))
(scm-error 'wrong-type-arg "make <authenticator>"
(G_ "#:server-uri should be an URI")
'()
(list server-uri)))))
(define-method (handle (endpoint <authenticator>) request request-body)
(define accumulated-error '())
(let ((headers (request-headers request))
(uri (request-uri request))
(method (request-method request)))
(let ((authz (assq-ref headers 'authorization))
(dpop (assq-ref headers 'dpop))
(full-uri
(let ((server-uri (server-uri endpoint)))
(build-uri (uri-scheme server-uri)
#:userinfo (uri-userinfo server-uri)
#:host (uri-host server-uri)
#:port (uri-port server-uri)
#:path
(string-append
(if (and (equal? (uri-path server-uri) "")
(equal? (uri-path uri) ""))
""
;; It must start with a / then
"/")
(encode-and-join-uri-path
(append
(split-and-decode-uri-path (uri-path server-uri))
(split-and-decode-uri-path (uri-path uri))))
(if (string-suffix? (uri-path uri) "/")
"/"
""))))))
(let ((user
(and authz dpop
(eq? (car authz) 'dpop)
(with-exception-handler
(lambda (error)
(if (exception-with-message? error)
(format (current-error-port)
(G_ "~a: authentication failure: ~a\n")
(date->string ((p:current-date)))
(exception-message error))
(format (current-error-port)
(G_ "~a: authentication failure\n")
(date->string ((p:current-date)))))
(set! accumulated-error
(make-exception
(make-user-message
(call-with-input-string
(format #f (W_ "<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"))
xml->sxml))
error))
#f)
(lambda ()
;; Sometimes the access is the cadr as a symbol,
;; sometimes it is the cdr as a string. It depends
;; whether the response has been written and read,
;; or preserved as a guile object.
(let* ((lit-access-token
(match authz
;; That’s when the request is parsed:
(('dpop (? symbol? symbol-value))
(symbol->string symbol-value))
;; That’s when it’s not:
(('dpop . (? string? string-value))
string-value)))
(access-token
(decode <access-token> lit-access-token))
(cnf/jkt (cnf/jkt access-token))
(dpop-proof
(decode <dpop-proof> dpop
#:method method
#:uri full-uri
#:cnf/check cnf/jkt
#:access-token lit-access-token)))
(let ((subject (webid access-token))
(issuer (iss access-token)))
(confirm-provider subject issuer)
subject)))
#:unwind? #t))))
(with-exception-handler
(lambda (exn)
;; Since a 401 might be returned normally or raised as
;; an exception, we won’t add the header to authenticate
;; with DPoP in this layer.
(raise-exception
(apply make-exception
exn
(make-caused-by-user user)
accumulated-error)))
(lambda ()
(receive (response response-body meta)
(handle (backend endpoint)
(build-request (request-uri request)
#:method (request-method request)
#:headers (request-headers request)
#:port (request-port request)
#:meta `((user . ,user)
,@(request-meta request)))
request-body)
(values response response-body `((user . ,user) ,@meta)))))))))
|
