blob: 6f96b44557bb4e20b958cb6e084df761c5950951 (
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
118
119
120
121
122
123
124
|
(define-module (webid-oidc identity-provider)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc authorization-endpoint)
#:use-module (webid-oidc token-endpoint)
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc jwk)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc jti)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web server)
#:use-module (webid-oidc cache)
#: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)
#:use-module (rnrs bytevectors))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define* (same-uri? a b #:key (skip-query #f))
(and (equal? (uri-path a) (uri-path b))
(or skip-query (equal? (uri-query a) (uri-query b)))))
(define*-public (make-identity-provider
issuer
key-file
subject
password
jwks-uri
authorization-endpoint-uri
token-endpoint-uri
jti-list
#:key
(current-time current-time)
(http-get http-get))
(let ((key
(catch #t
(lambda ()
(call-with-input-file key-file stubs:json->scm))
(lambda error
(format (current-error-port)
(G_ "Warning: generating a new key pair."))
(let ((k (generate-key #:n-size 2048)))
(stubs:call-with-output-file*
key-file
(lambda (port)
(stubs:scm->json k port #:pretty #t)))
k)))))
(let ((alg
(if (eq? (kty key) 'RSA)
'RS256
'ES256)))
(let ((authorization-endpoint
(make-authorization-endpoint subject password alg key 120
#:current-time current-time
#:http-get http-get))
(token-endpoint
(make-token-endpoint token-endpoint-uri issuer alg key 3600 jti-list
#:current-time current-time))
(openid-configuration
(make-oidc-configuration jwks-uri
authorization-endpoint-uri
token-endpoint-uri))
(openid-configuration-uri
(build-uri 'https
#:host (uri-host issuer)
#:path "/.well-known/openid-configuration")))
(lambda (request request-body)
(let ((uri (request-uri request))
(current-time (current-time)))
(cond ((same-uri? uri openid-configuration-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-oidc-configuration exp openid-configuration)))
((same-uri? uri jwks-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-jwks exp (make-jwks (list key)))))
((same-uri? uri authorization-endpoint-uri #:skip-query #t)
(authorization-endpoint request request-body))
((same-uri? uri token-endpoint-uri)
(token-endpoint request request-body))
((same-uri? uri subject)
(values
(build-response #:headers '((content-type text/turtle))
#:port #f)
(format #f
"@prefix foaf: <http://xmlns.com/foaf/0.1/> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
<#~a> a foaf:Person ;
rdfs:comment \"It works. Now you should use another service to serve that resource.\" .
"
(uri-fragment subject))))
(else
(values
(build-response #:code 404
#:reason-phrase "Not Found"
#:headers '((content-type application/xhtml+xml)))
(with-output-to-string
(lambda ()
(sxml->xml
`(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang "en"))
(body
(h1 "Resource not found")
(p "This OpenID Connect identity provider does not know the resource you are requesting."))))))))))))))))
|
