blob: 02f5ec7626a274b294c95dd2b273deea17c1676b (
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
|
(use-modules (webid-oidc client)
(webid-oidc testing)
(webid-oidc token-endpoint)
(webid-oidc jwk)
(webid-oidc jti)
(webid-oidc authorization-code)
(webid-oidc oidc-configuration)
(webid-oidc jws)
(webid-oidc oidc-id-token)
(web uri)
(web request)
(web response)
(srfi srfi-19)
(ice-9 optargs)
(ice-9 receive)
(ice-9 hash-table))
(with-test-environment
"client-token"
(lambda ()
(define the-current-time 0)
(define issuer-key (generate-key #:n-size 2048))
(define issuer-configuration
(make-oidc-configuration
"https://issuer.client-token.scm/keys"
"https://issuer.client-token.scm/authorize"
"https://issuer.client-token.scm/token"))
(define token-endpoint (make-token-endpoint
(string->uri "https://issuer.client-token.scm/token")
(string->uri "https://issuer.client-token.scm")
'RS256
issuer-key
3600 ;; 1 hour
(make-jti-list)
#:current-time (lambda () the-current-time)))
(define client-key (generate-key #:n-size 2048))
(define authorization-code
(issue-authorization-code 'RS256 issuer-key 120
(string->uri "https://client-token.scm/profile/card#me")
(string->uri "https://app.client-token.scm/app#id")))
(define* (http-get uri #:key (headers '()))
(cond
((equal? uri (string->uri "https://issuer.client-token.scm/.well-known/openid-configuration"))
(serve-oidc-configuration
(time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
issuer-configuration))
((equal? uri (string->uri "https://issuer.client-token.scm/keys"))
(serve-jwks
(time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
(make-jwks (list issuer-key))))
(else
(format (current-error-port) "GET request to ~a: error.\n" (uri->string uri))
(exit 1))))
(define* (http-post uri #:key (body #f) (headers '()))
(unless (equal? uri (oidc-configuration-token-endpoint issuer-configuration))
(format (current-error-port)
"Wrong URI for token negociation: ~a (expected ~a).\n"
(uri->string uri)
(uri->string
(oidc-configuration-token-endpoint
issuer-configuration)))
(exit 2))
(unless (equal? body (format #f "grant_type=authorization_code&code=~a"
authorization-code))
(format (current-error-port)
"Wrong body: ~s\n" body)
(exit 3))
(unless (equal?
(assoc-ref headers 'content-type)
'(application/x-www-form-urlencoded))
(format (current-error-port)
"Wrong content type: ~s\n" (assoc-ref headers 'content-type))
(exit 4))
(let ((request
(build-request uri
#:method 'POST
#:headers headers
#:port (open-input-string body)))
(request-body body))
(token-endpoint request request-body)))
(let ((response
(token "https://issuer.client-token.scm"
client-key
#:authorization-code authorization-code
#:http-get http-get
#:http-post http-post
#:current-time (lambda () the-current-time))))
(let ((id-token (assq-ref response 'id_token))
(access-token (assq-ref response 'access_token))
(token-type (assq-ref response 'token_type))
(token-expiration (assq-ref response 'expires_in))
(refresh-token (assq-ref response 'refresh_token)))
(let ((id-token-dec (id-token-decode id-token #:http-get http-get))
(access-token-dec (jws-decode access-token (lambda (jws) issuer-key))))
(unless id-token-dec
(format (current-error-port) "Could not decode the ID token from ~s (~s)"
id-token response)
(exit 5))
(unless access-token-dec
(format (current-error-port) "Could not decode the access token from ~s (~s)"
access-token response)
(exit 6))
(unless refresh-token
(format (current-error-port) "There does not seem to be a refresh token in ~s"
response)
(exit 6))
(unless (equal? (id-token-webid id-token-dec)
(string->uri "https://client-token.scm/profile/card#me"))
(exit 7))
(unless (equal? (id-token-iss id-token-dec)
(string->uri "https://issuer.client-token.scm"))
(exit 8))
(unless (equal? (id-token-aud id-token-dec)
(string->uri "https://app.client-token.scm/app#id"))
(exit 9))
;; It’s not the job of the client to check that the access
;; token is correct; TODO: add a check with a resource
;; server.
;; TODO: try to negociate a refresh token.
)))))
|
