) 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_ "There is an access token and a DPoP proof, but one or both is invalid.
"))
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 lit-access-token))
(cnf/jkt (cnf/jkt access-token))
(dpop-proof
(decode 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)))))))))