blob: 99a4e17c25f358f698da5eea6c8d6a39d01e6fec (
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
(define-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-19)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs))
(define-public (the-oidc-configuration x)
(with-exception-handler
(lambda (cause)
(raise-not-an-oidc-configuration x cause))
(lambda ()
(let ((jwks-uri (assq-ref x 'jwks_uri))
(token-endpoint (assq-ref x 'token_endpoint))
(authorization-endpoint (assq-ref x 'authorization_endpoint)))
(unless jwks-uri
(raise-missing-alist-key x 'jwks_uri))
(unless token-endpoint
(raise-missing-alist-key x 'token_endpoint))
(unless authorization-endpoint
(raise-missing-alist-key x 'authorization_endpoint))
(for-each
(lambda (field)
(unless (string->uri field)
(scm-error 'wrong-type-arg
"the-oidc-configuration"
"expected an uri-like string"
'()
(list field))))
(list jwks-uri token-endpoint authorization-endpoint))
x))))
(define-public (oidc-configuration? obj)
(false-if-exception
(and (the-oidc-configuration obj) obj)))
(define-public (make-oidc-configuration jwks-uri
authorization-endpoint
token-endpoint)
(when (string? jwks-uri)
(set! jwks-uri (string->uri jwks-uri)))
(when (string? authorization-endpoint)
(set! authorization-endpoint (string->uri authorization-endpoint)))
(when (string? token-endpoint)
(set! token-endpoint (string->uri token-endpoint)))
(the-oidc-configuration
`((jwks_uri . ,(uri->string jwks-uri))
(token_endpoint . ,(uri->string token-endpoint))
(authorization_endpoint . ,(uri->string authorization-endpoint)))))
(define (uri-field what)
(lambda (x)
(let ((str (assq-ref (the-oidc-configuration x) what)))
(string->uri str))))
(define-public oidc-configuration-jwks-uri
(uri-field 'jwks_uri))
(define-public oidc-configuration-authorization-endpoint
(uri-field 'authorization_endpoint))
(define-public oidc-configuration-token-endpoint
(uri-field 'token_endpoint))
(define-public (oidc-configuration-jwks cfg . args)
(apply get-jwks (oidc-configuration-jwks-uri cfg) args))
(define-public (serve-oidc-configuration expiration-date cfg)
(let ((with-solid-oidc-supported
(acons 'solid_oidc_supported "https://solidproject.org/TR/solid-oidc"
(the-oidc-configuration cfg))))
(values (build-response #:headers `((content-type . (application/json))
(expires . ,expiration-date)))
(stubs:scm->json-string with-solid-oidc-supported))))
(define*-public (get-oidc-configuration host
#:key
(userinfo #f)
(port #f)
(http-get http-get))
(when (and (string? host)
(false-if-exception
(string->uri host)))
;; host is something like "https://example.com"
(set! host (string->uri host)))
(when (uri? host)
(set! host (uri-host host)))
(let ((uri (build-uri 'https
#:userinfo userinfo
#:host host
#:port port
#:path "/.well-known/openid-configuration")))
(receive (response response-body) (http-get uri)
(with-exception-handler
(lambda (cause)
(raise-unexpected-response response cause))
(lambda ()
(unless (eqv? (response-code response) 200)
(raise-request-failed-unexpectedly
(response-code response)
(response-reason-phrase response)))
(let ((content-type (response-content-type response)))
(unless content-type
(raise-unexpected-header-value 'content-type content-type))
(unless (and (eq? (car content-type) 'application/json)
(or (equal? (assoc-ref (cdr content-type) 'charset)
"utf-8")
(not (assoc-ref (cdr content-type) 'charset))))
(raise-unexpected-header-value 'content-type content-type))
(unless (string? response-body)
(set! response-body (utf8->string response-body)))
(the-oidc-configuration (stubs:json-string->scm response-body))))))))
|
