blob: cef6a0ced5c7a286323beba2429f309559635b48 (
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
|
(define-module (webid-oidc resource-server)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc provider-confirmation)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc dpop-proof)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc access-token)
#: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 (ice-9 i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (sxml simple)
#:use-module (srfi srfi-19))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define*-public (make-authenticator jti-list
#:key
(server-uri #f)
(current-time current-time)
(http-get http-get))
(unless (and server-uri (uri? server-uri))
(error "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))
(lambda (request request-body)
(let ((headers (request-headers request))
(uri (request-uri request))
(method (request-method request))
(current-time
(let ((t current-time))
(when (thunk? t)
(set! t (t)))
(when (integer? t)
(set! t (make-time time-utc 0 t)))
(when (time? t)
(set! t (time-utc->date t)))
t)))
(let ((authz (assoc-ref headers 'authorization))
(dpop (assoc-ref headers 'dpop))
(full-uri (build-uri (uri-scheme server-uri)
#:userinfo (uri-userinfo server-uri)
#:host (uri-host server-uri)
#:port (uri-port server-uri)
#:path (string-append
"/"
(encode-and-join-uri-path
(append
(split-and-decode-uri-path (uri-path server-uri))
(split-and-decode-uri-path
(uri-path uri))))))))
(and authz dpop
(eq? (car authz) 'dpop)
(with-exception-handler
(lambda (error)
(format (current-error-port)
(G_ "~a: authentication failure: ~a\n")
(date->string current-time)
(error->str error))
#f)
(lambda ()
(let* ((access-token
(access-token-decode
(symbol->string (cadr authz))
#:http-get http-get))
(cnf/jkt (access-token-cnf/jkt access-token))
(dpop-proof
(dpop-proof-decode
current-time jti-list method full-uri
dpop cnf/jkt)))
(let ((subject (access-token-webid access-token))
(issuer (access-token-iss access-token)))
(confirm-provider subject issuer #:http-get http-get)
subject)))
#:unwind? #t))))))
|
