blob: cc4d46aa00001ffd7655fc4705956db773e8e083 (
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
|
(define-module (webid-oidc reverse-proxy)
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc resource-server)
#:use-module (webid-oidc jti)
#:use-module ((webid-oidc config) #:prefix cfg:)
#: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 (srfi srfi-19)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (web client)
#:use-module (webid-oidc cache)
#:use-module (web server))
(define*-public (make-reverse-proxy
#:key
(jti-list #f)
(server-uri #f)
(current-time current-time)
(http-get http-get)
(endpoint #f)
(auth-header 'XXX-Agent))
(set! auth-header
;; We need to remove the lowercase version of auth-header from
;; all incoming requests!
(string->symbol
(string-downcase
(symbol->string auth-header))))
(define authenticate
(make-authenticator
(or jti-list (make-jti-list))
#:server-uri server-uri
#:current-time current-time
#:http-get http-get))
(unless (and endpoint (uri? endpoint))
(error "#:endpoint argument is not present or not an URI."))
(lambda (request request-body)
(let ((agent
(catch #t
(lambda ()
(authenticate request request-body))
(lambda (key . args)
(case key
((invalid-access-token
invalid-proof
unconfirmed-issuer)
#f)
(else
(apply throw key args)))))))
(let ((raw-headers (request-headers request)))
(let ((modified-headers
(append
(if agent
(list (cons auth-header (uri->string agent)))
'())
(filter
(lambda (h)
(not (eq? (car h) auth-header)))
raw-headers))))
(let ((modified-request
(build-request
(request-uri request)
#:method (request-method request)
#:headers modified-headers)))
(let ((port (open-socket-for-uri endpoint)))
(let ((request-with-port
(write-request modified-request port)))
(when request-body
(unless (bytevector? request-body)
(set! request-body (string->utf8 request-body)))
(write-request-body request-with-port request-body))
(force-output (request-port request-with-port))
(let ((response (read-response port)))
(let ((response-body
(or (response-must-not-include-body? response)
(read-response-body response))))
(let ((adapted-response
(build-response
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)
#:headers
(append
(if (eqv? (response-code response) 401)
(list (cons 'www-authenticate '((DPoP))))
'())
(response-headers response)))))
(close-port port)
(values adapted-response response-body))))))))))))
|
