diff options
Diffstat (limited to 'src/scm')
21 files changed, 777 insertions, 861 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index acd9ec9..3e92bd3 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -46,7 +46,8 @@ dist_webidoidcmod_DATA += \ %reldir%/rdf-index.scm \ %reldir%/http-link.scm \ %reldir%/offloading.scm \ - %reldir%/catalog.scm + %reldir%/catalog.scm \ + %reldir%/parameters.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -80,7 +81,8 @@ webidoidcgo_DATA += \ %reldir%/rdf-index.go \ %reldir%/http-link.go \ %reldir%/offloading.go \ - %reldir%/catalog.go + %reldir%/catalog.go \ + %reldir%/parameters.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index 9c57326..acdc56f 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-configuration) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web client) #:use-module (ice-9 optargs) @@ -206,8 +207,7 @@ (alg #f) (webid #f) (iss #f) - (iat #f) - (exp #f) + (validity 3600) (client-key #f) (cnf/jkt #f) (client-id #f)) @@ -216,6 +216,7 @@ (access-token-encode (make-access-token `((alg . ,(if (symbol? alg) (symbol->string alg) alg))) - (make-access-token-payload - webid iss iat exp cnf/jkt client-id)) + (let ((iat (time-second (date->time-utc ((p:current-date)))))) + (make-access-token-payload + webid iss iat (+ iat validity) cnf/jkt client-id))) issuer-key)) diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 3a0da3b..267d67a 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (srfi srfi-19)) @@ -129,28 +130,26 @@ (string->uri (assq-ref (the-authorization-code-payload code) 'client_id))) -(define-public (authorization-code-decode current-time jti-list str jwk) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (with-exception-handler - (lambda (error) - (raise-cannot-decode-authorization-code str error)) - (lambda () - (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) - (let ((exp (time-second (date->time-utc (authorization-code-exp code))))) - (unless (<= current-time exp) - (raise-authorization-code-expired exp current-time)) - (unless (jti-check current-time (authorization-code-jti code) - jti-list - (- exp current-time)) - (with-exception-handler - (lambda (error) - (raise-jti-found (authorization-code-jti code) error)) - (lambda () - (error "the jti-check function returned #f")))) - code))))) +(define-public (authorization-code-decode str jwk) + (parameterize ((p:current-date + (time-second (date->time-utc ((p:current-date)))))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-authorization-code str error)) + (lambda () + (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) + (let ((exp (time-second (date->time-utc (authorization-code-exp code)))) + (current-time (time-second (date->time-utc ((p:current-date)))))) + (unless (<= current-time exp) + (raise-authorization-code-expired exp current-time)) + (unless (jti-check (authorization-code-jti code) + (- exp current-time)) + (with-exception-handler + (lambda (error) + (raise-jti-found (authorization-code-jti code) error)) + (lambda () + (error "the jti-check function returned #f")))) + code)))))) (define-public (authorization-code-encode authorization-code key) (with-exception-handler diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index 9ff994c..d5591b7 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc authorization-code) #:use-module (webid-oidc client-manifest) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web client) #:use-module (web request) @@ -35,8 +36,7 @@ (define*-public (make-authorization-endpoint subject encrypted-password alg jwk validity #:key - (http-get http-get) - (current-time current-time)) + (http-get http-get)) (define (parse-arg x decode-plus-to-space?) (map (lambda (x) (uri-decode x @@ -90,16 +90,9 @@ (lambda (error) (error-application locale error)) (lambda () - (let* ((current-time (if (thunk? current-time) - (current-time) - current-time)) + (let* ((current-time ((p:current-date))) ;; current-date is a thunk parameter (current-sec - (cond ((date? current-time) - (time-second (date->time-utc current-time))) - ((time? current-time) - (time-second current-time)) - ((integer? current-time) - current-time))) + (time-second (date->time-utc current-time))) (exp-sec (+ current-sec validity)) (exp (time-utc->date (make-time time-utc 0 exp-sec))) (code (issue-authorization-code alg jwk exp subject client-id))) diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index dbf0112..e98f87f 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -16,6 +16,7 @@ (define-module (webid-oidc cache) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web client) #:use-module (web request) #:use-module (web response) @@ -24,7 +25,17 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:export + ( + clean-cache + add + read + varies? + valid? + revalidate + with-cache + )) ;; The cache follows the recommendations of ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching @@ -48,36 +59,26 @@ ;; There is a global lock file at the root of the cache, which serves ;; for region locking. Do not remove it! -(define (default-cache-dir) - (let ((xdg-cache-home - (or (getenv "XDG_CACHE_HOME") - (format #f "~a/.cache" (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-cache-home))) +(define (web-cache-dir) + (string-append (p:cache-home) "/web-cache/")) -(define (web-cache-dir dir) - (when (thunk? dir) - (set! dir (dir))) - (string-append dir - "/web-cache/")) - -(define (file-name uri dir) +(define (file-name uri) (when (string? uri) (set! uri (string->uri uri))) - (string-append (web-cache-dir dir) + (string-append (web-cache-dir) (stubs:hash 'SHA-256 (uri->string uri)))) -(define (lock-file-name dir) - (string-append (web-cache-dir dir) ".lock")) +(define (lock-file-name) + (string-append (web-cache-dir) ".lock")) (define (event? percents) (<= (* (random:uniform) 100) percents)) -(define*-public (clean-cache - #:key - (percents 5) - (dir default-cache-dir)) - (define lock-file (lock-file-name dir)) +(define* (clean-cache + #:key + (percents 5)) + (define lock-file (lock-file-name)) (define (survives?) (not (event? percents))) (define (enter? name stat result) @@ -104,14 +105,13 @@ name (strerror errno)) result) (file-system-fold enter? leaf down up skip error 0 - (web-cache-dir dir))) + (web-cache-dir))) (define (maybe-clean-cache pc-happen - pc-cleaned - dir) + pc-cleaned) (when (event? pc-happen) - (clean-cache #:percents pc-cleaned #:dir dir))) + (clean-cache #:percents pc-cleaned))) (define (remove-uncacheable-headers response) (let ((headers (response-headers response))) @@ -129,16 +129,15 @@ #:headers filtered #:port #f)))) -(define*-public (add request response response-body - #:key (dir default-cache-dir)) +(define (add request response response-body) ;; Don’t store it if there’s a cache-control no-store (unless (let ((cc (response-cache-control response '()))) (assq-ref cc 'no-store)) (set! response (remove-uncacheable-headers response)) - (let ((final-file-name (file-name (request-uri request) dir)) - (lock-file (lock-file-name dir))) - (maybe-clean-cache 5 5 dir) + (let ((final-file-name (file-name (request-uri request))) + (lock-file (lock-file-name))) + (maybe-clean-cache 5 5) (stubs:atomically-update-file final-file-name lock-file @@ -152,14 +151,8 @@ (write-response-body file-response response-body)) #t)))))) -(define (the-current-time) - (time-utc->date - (current-time))) - -(define*-public (read uri - #:key - (dir default-cache-dir)) - (let ((final-file-name (file-name uri dir))) +(define (read uri) + (let ((final-file-name (file-name uri))) (catch 'system-error (lambda () (call-with-input-file final-file-name @@ -183,60 +176,46 @@ (or (varies-header? request-a request-b (car headers)) (varies-any-header? request-a request-b (cdr headers))))) -(define-public (varies? request-a request-b response) +(define (varies? request-a request-b response) (let ((vary (response-vary response))) (or (eq? vary '*) (varies-any-header? request-a request-b vary)))) -(define*-public (valid? response - #:key - (current-time the-current-time)) - (when (thunk? current-time) - (set! current-time (current-time))) - (when (integer? current-time) - (set! current-time - (make-time time-utc 0 current-time))) - (when (time? current-time) - (set! current-time (time-utc->date current-time))) - (set! current-time - (date->time-utc current-time)) - (set! current-time - (time-second current-time)) - (let ((cc (response-cache-control response #f)) - (date (response-date response - (time-utc->date - (make-time time-utc 0 current-time)))) - (last-modified (response-last-modified response))) - (set! date (date->time-utc date)) - (set! date (time-second date)) - (when last-modified - (set! last-modified (date->time-utc last-modified)) - (set! last-modified (time-second last-modified))) - (if cc - ;; Use cache-control - (let ((cc-no-cache (assq-ref cc 'no-cache)) - (cc-no-store (assq-ref cc 'no-store)) - (cc-max-age - (or (assq-ref cc 'max-age) - ;; Heuristic freshness - (and last-modified - (/ (- date last-modified) 10))))) - (and (not cc-no-cache) - (not cc-no-store) - cc-max-age - (>= (+ date cc-max-age) current-time))) - ;; Use expires - (let ((exp (response-expires response))) - (when exp - (set! exp (date->time-utc exp)) - (set! exp (time-second exp))) - (and exp - (>= exp current-time)))))) +(define (valid? response) + ;; current-date is a thunk parameter + (let* ((current-date ((p:current-date))) + (current-time (time-second (date->time-utc current-date)))) + (let ((cc (response-cache-control response #f)) + (date (time-second (date->time-utc (response-date response current-date)))) + (last-modified + (let ((as-date (response-last-modified response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (if cc + ;; Use cache-control + (let ((cc-no-cache (assq-ref cc 'no-cache)) + (cc-no-store (assq-ref cc 'no-store)) + (cc-max-age + (or (assq-ref cc 'max-age) + ;; Heuristic freshness + (and last-modified + (/ (- date last-modified) 10))))) + (and (not cc-no-cache) + (not cc-no-store) + cc-max-age + (>= (+ date cc-max-age) current-time))) + ;; Use expires + (let ((exp + (let ((as-date (response-expires response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (and exp + (>= exp current-time))))))) -(define*-public (revalidate uri response body - #:key - (headers '()) - (http-get http-get)) +(define* (revalidate uri response body + #:key + (headers '()) + (http-get http-get)) (define (keep-header? h) (case (car h) ((if-none-match if-unmodified-since) #f) @@ -266,20 +245,14 @@ (values new-response new-response-body))) (http-get uri #:headers headers)))) -(define*-public (with-cache - #:key - (current-time the-current-time) - (http-get http-get) - (dir default-cache-dir)) +(define* (with-cache #:key (http-get http-get)) (lambda* (uri #:key (headers '())) (when (string? uri) (set! uri (string->uri uri))) - (let ((dir (if (thunk? dir) (dir) dir)) - (request (build-request uri #:headers headers))) - (receive (stored-request stored-response body) - (read uri #:dir dir) + (let ((request (build-request uri #:headers headers))) + (receive (stored-request stored-response body) (read uri) (if stored-response - (let ((valid (valid? stored-response #:current-time the-current-time)) + (let ((valid (valid? stored-response)) (invariant (not (varies? request stored-request stored-response)))) (unless invariant (format (current-error-port) "Cache entry for ~a varies.\n" (uri->string uri))) @@ -289,9 +262,9 @@ (revalidate uri stored-response body #:headers headers #:http-get http-get) - (add request final-response final-body #:dir dir) + (add request final-response final-body) (values final-response final-body)))) (receive (final-response final-body) (http-get uri #:headers headers) - (add request final-response final-body #:dir dir) + (add request final-response final-body) (values final-response final-body))))))) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index e8796c0..67928db 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -21,8 +21,8 @@ #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web uri) #:use-module (web client) @@ -174,28 +174,17 @@ (raise-no-provider-candidates host-or-webid candidate-errors)) final-candidates)))))) -(define the-current-time current-time) - (define*-public (token host client-key #:key (authorization-code #f) (refresh-token #f) (http-get http-get) - (http-post http-post) - (current-time #f)) + (http-post http-post)) (unless (or authorization-code refresh-token) (scm-error 'wrong-type-arg "token" "You need to either set #:authorization-code or #:refresh-token." '() (list authorization-code))) - (unless current-time - (set! current-time the-current-time)) - (when (thunk? current-time) - (set! current-time (current-time))) - (when (integer? current-time) - (set! current-time (make-time time-utc 0 current-time))) - (when (time? current-time) - (set! current-time (time-utc->date current-time))) (let ((token-endpoint (oidc-configuration-token-endpoint (get-oidc-configuration host #:http-get http-get))) @@ -212,8 +201,7 @@ (else (error "Unknown key type of ~S." client-key))) #:htm 'POST - #:htu token-endpoint - #:iat current-time))) + #:htu token-endpoint))) (receive (response response-body) (http-post token-endpoint #:body @@ -253,17 +241,7 @@ (raise-unexpected-header-value 'content-type (response-content-type response))) (stubs:json-string->scm response-body))))))))) -(define (default-dir) - (let ((xdg-data-home - (or - (getenv "XDG_DATA_HOME") - (format #f "~a/.local/share" - (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-data-home))) - -(define*-public (list-profiles #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define-public (list-profiles) (map (lambda (profile) (list (string->uri (car profile)) ;; webid @@ -272,20 +250,17 @@ (cadddr profile))) ;; key (catch #t (lambda () - (call-with-input-file (string-append dir "/profiles") + (call-with-input-file (string-append (p:data-home) "/profiles") read)) (lambda error (format (current-error-port) "Could not read profiles: ~s\n" error) '())))) -(define* (add-profile webid issuer refresh-token key - #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) - (let ((other-profiles (list-profiles #:dir dir))) +(define (add-profile webid issuer refresh-token key) + (let ((other-profiles (list-profiles))) (stubs:atomically-update-file - (string-append dir "/profiles") - (string-append dir "/profiles.lock") + (string-append (p:data-home) "/profiles") + (string-append (p:data-home) "/profiles.lock") (lambda (port) (write (map (lambda (profile) @@ -304,12 +279,8 @@ #:key (client-id #f) (redirect-uri #f) - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) - (when (thunk? dir) - (set! dir (dir))) + (http-post http-post)) (let ((host/webid (get-host/webid))) (let ((authorization-uris (authorize host/webid @@ -324,8 +295,7 @@ (token host/webid key #:authorization-code authz-code #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #:http-post http-post))) (let ((id-token (id-token-decode (assq-ref params 'id_token) #:http-get http-get)) (access-token (assq-ref params 'access_token)) @@ -335,16 +305,13 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (values (cdr id-token) access-token key))))))))) (define*-public (login webid issuer refresh-token key #:key - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) + (http-post http-post)) (when (string? webid) (set! webid (string->uri webid))) (when (string? issuer) @@ -354,8 +321,7 @@ (token iss-host key #:refresh-token refresh-token #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #:http-post http-post))) (let ((id-token (id-token-decode (assq-ref params 'id_token) #:http-get http-get)) (access-token (assq-ref params 'access_token)) @@ -366,30 +332,25 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (values (cdr id-token) access-token key))))) (define*-public (refresh id-token key #:key - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) - (when (thunk? dir) - (set! dir (dir))) + (http-post http-post)) (when (id-token-payload? id-token) ;; For convenience, we’d like a full ID token to use the ID token ;; API. (set! id-token (cons `((alg . "HS256")) id-token))) - (let ((profiles (list-profiles #:dir dir))) + (let ((profiles (list-profiles))) (letrec ((find-refresh-token (lambda (profiles) (when (null? profiles) (raise-profile-not-found (id-token-webid id-token) (id-token-iss id-token) - dir)) + (p:data-home))) (let ((prof (car profiles)) (others (cdr profiles))) (let ((webid (car prof)) @@ -403,15 +364,12 @@ (id-token-iss id-token) (find-refresh-token (profiles)) key - #:dir dir #:http-get http-get - #:http-post http-post - #:current-time current-time)))) + #:http-post http-post)))) (define* (renew-if-expired id-token access-token key date #:key - (dir default-dir) (http-get http-get) (http-post http-post)) ;; Since we’re not supposed to decode the access token, we’re @@ -427,25 +385,22 @@ (set! exp (date->time-utc exp)) (set! exp (time-second exp)) (if (>= date exp) - (refresh id-token key - #:dir dir - #:http-get http-get - #:http-post http-post - #:current-time date) + (parameterize ((p:current-date (lambda () date))) + (refresh id-token key + #:http-get http-get + #:http-post http-post)) (values id-token access-token key)))) (define*-public (make-client id-token access-token key #:key - (dir default-dir) (http-get http-get) (http-post http-post) - (http-request http-request) - (current-time the-current-time)) + (http-request http-request)) ;; HACK: guile does not support other authentication schemes in ;; WWW-Authenticate than Basic, so it will crash when a response ;; containing that header will be issued. (declare-header! "WWW-Authenticate" string->symbol symbol? write) - (define (handler uri method headers other-args current-time retry?) + (define (handler uri method headers other-args retry?) (let ((proof (issue-dpop-proof key #:alg (case (kty key) @@ -455,7 +410,6 @@ (error "Unknown key type of ~S." key))) #:htm method #:htu uri - #:iat current-time #:access-token access-token))) (receive (response response-body) (apply http-request uri @@ -470,7 +424,6 @@ ;; Maybe the access token has expired? (receive (new-id-token new-access-token new-key) (renew-if-expired id-token access-token key server-date - #:dir dir #:http-get http-get #:http-post http-post) (if (equal? access-token new-access-token) @@ -481,18 +434,11 @@ (set! id-token new-id-token) (set! access-token new-access-token) (set! key new-key) - (handler uri method headers other-args current-time #f)))) + (handler uri method headers other-args #f)))) (values response response-body)))))) (define (parse-args uri method headers other-args-rev rest) (if (null? rest) - (let ((the-current-time current-time)) - (when (thunk? the-current-time) - (set! the-current-time (the-current-time))) - (when (integer? the-current-time) - (set! the-current-time (make-time time-utc 0 the-current-time))) - (when (time? the-current-time) - (set! the-current-time (time-utc->date the-current-time))) - (handler uri method headers (reverse other-args-rev) the-current-time #t)) + (handler uri method headers (reverse other-args-rev) #t) (let ((kw (car rest))) (case kw ((#:method) @@ -618,5 +564,3 @@ (title "Not Found")) (body (p "This page does not exist on the server.")))))))))))))) - - diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index 54b338b..2ccbddc 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc jti) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (ice-9 optargs) #:use-module (srfi srfi-19)) @@ -186,51 +187,51 @@ (uri-path b)))) (raise-dpop-uri-mismatch a b))) -(define*-public (dpop-proof-decode current-time jti-list method uri str cnf/check +(define*-public (dpop-proof-decode method uri str cnf/check #:key (access-token #f)) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (with-exception-handler - (lambda (error) - (raise-cannot-decode-dpop-proof str error)) - (lambda () - (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) - (unless (eq? method (dpop-proof-htm decoded)) - (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) - (uris-compatible (dpop-proof-htu decoded) - (if (string? uri) - (string->uri uri) - uri)) - (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) - (unless (>= current-time (- iat 5)) - (raise-dpop-signed-in-future iat current-time)) - (unless (<= current-time (+ iat 120)) ;; Valid for 2 min - (raise-dpop-too-old iat current-time))) - (when access-token - (let ((h (stubs:hash 'SHA-256 access-token))) - (unless (equal? (dpop-proof-ath decoded) h) - (raise-exception - (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) - (if (string? cnf/check) - (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) - (with-exception-handler - (lambda (error) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) - (lambda () - (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - ;; deprecated; throw an error instead! - (error "the cnf/check function returned #f"))))) - (unless (jti-check current-time (dpop-proof-jti decoded) jti-list 120) - (with-exception-handler - (lambda (error) - (raise-jti-found (dpop-proof-jti decoded) error)) - (lambda () - (error "the jti-check function returned #f")))) - decoded)))) + (let ((current-time + (time-second (date->time-utc ((p:current-date)))))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-dpop-proof str error)) + (lambda () + (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) + (unless (eq? method (dpop-proof-htm decoded)) + (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) + (uris-compatible (dpop-proof-htu decoded) + (if (string? uri) + (string->uri uri) + uri)) + (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) + (unless (>= current-time (- iat 5)) + (raise-dpop-signed-in-future iat current-time)) + (unless (<= current-time (+ iat 120)) ;; Valid for 2 min + (raise-dpop-too-old iat current-time))) + (when access-token + (let ((h (stubs:hash 'SHA-256 access-token))) + (unless (equal? (dpop-proof-ath decoded) h) + (raise-exception + (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) + (if (string? cnf/check) + (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) + (with-exception-handler + (lambda (error) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) + (lambda () + (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + ;; deprecated; throw an error instead! + (error "the cnf/check function returned #f"))))) + (parameterize ((p:current-date current-time)) + ;; jti-check should use the same date. + (unless (jti-check (dpop-proof-jti decoded) 120) + (with-exception-handler + (lambda (error) + (raise-jti-found (dpop-proof-jti decoded) error)) + (lambda () + (error "the jti-check function returned #f")))) + decoded)))))) (define-public (dpop-proof-encode dpop-proof key) (with-exception-handler @@ -245,11 +246,10 @@ (alg #f) (htm #f) (htu #f) - (iat #f) (access-token #f)) (dpop-proof-encode (make-dpop-proof (make-dpop-proof-header alg client-key) - (make-dpop-proof-payload (stubs:random 12) htm htu iat + (make-dpop-proof-payload (stubs:random 12) htm htu ((p:current-date)) (and access-token (stubs:hash 'SHA-256 access-token)))) client-key)) diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm index 8e68359..d752aae 100644 --- a/src/scm/webid-oidc/hello-world.scm +++ b/src/scm/webid-oidc/hello-world.scm @@ -17,7 +17,6 @@ (define-module (webid-oidc hello-world) #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server log) - #:use-module (webid-oidc jti) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web request) #:use-module (web response) @@ -112,7 +111,6 @@ Options: (G_ "You are legally required to link to the complete corresponding source code.\n")) (exit 1)) str)) - (jti-list (make-jti-list)) (log-file (option-ref options log-file-sym #f)) (error-file (option-ref options error-file-sym #f))) (unless (and (string->number port-string) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index 8bd3e5b..e22f1ef 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -57,9 +57,7 @@ jwks-uri authorization-endpoint-uri token-endpoint-uri - jti-list #:key - (current-time current-time) (http-get http-get)) (let ((key (catch #t @@ -80,11 +78,9 @@ 'ES256))) (let ((authorization-endpoint (make-authorization-endpoint subject encrypted-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)) + (make-token-endpoint token-endpoint-uri issuer alg key 3600)) (openid-configuration (make-oidc-configuration jwks-uri authorization-endpoint-uri diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm index 4713d7d..cf05bbb 100644 --- a/src/scm/webid-oidc/jti.scm +++ b/src/scm/webid-oidc/jti.scm @@ -15,36 +15,42 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc jti) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 atomic) #:use-module (ice-9 threads) - #:use-module (srfi srfi-19)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:export (jti-check)) -(define-public (make-jti-list) +(define jti-list (make-atomic-box '())) -(define-public (lookup list jti) - (if (null? list) - #f - (or (string=? (assq-ref (car list) 'jti) jti) - (lookup (cdr list) jti)))) - -(define-public (jti-check current-time jti list valid-time) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (let* ((old (atomic-box-ref list)) - (new-entry `((exp . ,(+ current-time valid-time)) - (jti . ,jti))) +(define-record-type <jti-item> + (make-jti-item exp jti) + jti-item? + (exp jti-item-exp) + (jti jti-item-jti)) + +(define lookup + (match-lambda* + ((() item) #f) + (((($ <jti-item> exp jti) other ...) item) + (or (string=? jti item) + (lookup other item))))) + +(define (jti-check jti valid-time) + (let* ((current-time + (time-second (date->time-utc ((p:current-date))))) + (old (atomic-box-ref jti-list)) + (new-entry (make-jti-item (+ current-time valid-time) jti)) (new (filter - (lambda (entry) - (let ((exp (assq-ref entry 'exp))) - (>= exp current-time))) + (match-lambda + (($ <jti-item> exp other-jti) + (>= exp current-time))) (cons new-entry old)))) - (let ((present? (lookup old jti))) - (if present? - #f - (let ((discarded (atomic-box-compare-and-swap! list old new))) - (if (eq? discarded old) - #t - (jti-check current-time jti list valid-time))))))) + (and (not (lookup old jti)) + (let ((discarded (atomic-box-compare-and-swap! jti-list old new))) + (if (eq? discarded old) + #t + (jti-check jti valid-time)))))) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index 9fe276c..e95efaf 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web client) #:use-module (ice-9 optargs) @@ -206,12 +207,13 @@ (iss #f) (sub #f) (aud #f) - (exp #f) - (iat #f)) + (validity 3600)) (unless sub (set! sub webid)) (id-token-encode (make-id-token `((alg . ,(symbol->string alg))) - (make-id-token-payload webid iss sub aud (stubs:random 12) exp iat)) + (let ((iat (time-second (date->time-utc ((p:current-date)))))) + (make-id-token-payload webid iss sub aud (stubs:random 12) + (+ iat validity) iat))) issuer-key)) diff --git a/src/scm/webid-oidc/parameters.scm b/src/scm/webid-oidc/parameters.scm new file mode 100644 index 0000000..3b24361 --- /dev/null +++ b/src/scm/webid-oidc/parameters.scm @@ -0,0 +1,34 @@ +(define-module (webid-oidc parameters) + #:use-module (srfi srfi-19) + #:use-module (webid-oidc jti) + #:export (data-home cache-home current-date)) + +(define data-home + (make-parameter + (format #f "~a/disfluid" + (or (getenv "XDG_DATA_HOME") + (format #f "~a/.local/share" + (getenv "HOME")))))) + +(define cache-home + (make-parameter + (format #f "~a/disfluid" + (or (getenv "XDG_CACHE_HOME") + (format #f "~a/.cache" + (getenv "HOME")))))) + +(define current-date + ;; This parameter is a thunk! + (make-parameter + (lambda () + (time-utc->date (current-time))) + (lambda (thunk) + (lambda () + (let ((date (if (thunk? thunk) + (thunk) + thunk))) + (when (integer? date) + (set! date (make-time time-utc 0 date))) + (when (time? date) + (set! date (time-utc->date date))) + date))))) diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 2eda34c..9d65b70 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -25,6 +25,7 @@ #:use-module (webid-oidc jti) #:use-module (webid-oidc offloading) #:use-module (webid-oidc catalog) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (ice-9 optargs) @@ -103,81 +104,95 @@ (prepare-log-file log-file)) (when error-file (prepare-error-file error-file)) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "~a: ~a: Internal server error: ~a\n") - (date->string (time-utc->date (current-time))) - (request-ip-address request) - (error->str error))) - (return - (build-response #:code 500 - #:reason-phrase "Internal Server Error" - #:headers `((source . ,complete-corresponding-source))) - "Sorry, there was an error.")) - (lambda () - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") - ((record-accessor &unknown-client-locale 'web-locale) error) - ((record-accessor &unknown-client-locale 'c-locale) error) - (error->str error)))) - (lambda () - (receive (response response-body user cause) - (call-with-values - (lambda () - (handler request request-body)) - (case-lambda - ((response response-body) - (values response response-body #f #f)) - ((response response-body user) - (values response response-body user #f)) - ((response response-body user cause) - (values response response-body user cause)))) - (let ((logging-port - (let ((response-code (response-code response))) - (if (>= response-code 400) - ;; That’s an error - (current-error-port) - (current-output-port))))) + (parameterize ((p:data-home + (string-append + (or (getenv "XDG_DATA_HOME") + (string-append (getenv "HOME") "/.local/share")) + "/disfluid")) + (p:cache-home + (string-append + (or (getenv "XDG_CACHE_HOME") + (string-append (getenv "HOME") "/.cache")) + "/disfluid")) + ;; Fix the date + (p:current-date ((p:current-date)))) + (call/ec + (lambda (return) + (with-exception-handler + (lambda (error) + (with-mutex logging-mutex + (format (current-error-port) + (G_ "~a: ~a: Internal server error: ~a\n") + (date->string ((p:current-date))) + (request-ip-address request) + (error->str error))) + (return + (build-response #:code 500 + #:reason-phrase "Internal Server Error" + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))))) + "Sorry, there was an error.")) + (lambda () + (with-exception-handler + (lambda (error) (with-mutex logging-mutex - (format logging-port - (G_ "~a: ~s ~a ~s ~a\n") - (if user - (format #f (G_ "~a: ~a (~a)") - (date->string (time-utc->date (current-time))) - (uri->string user) - (request-ip-address request)) - (format #f (G_ "~a: ~a") - (date->string (time-utc->date (current-time))) - (request-ip-address request))) - (request-method request) - (uri-path (request-uri request)) - (response-code response) - (if cause - (string-append - (response-reason-phrase response) - " " - (format #f (G_ "(there was an error: ~a)") - (error->str cause))) - (response-reason-phrase response))))) - (return - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers (cons `(source . ,complete-corresponding-source) - (response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t - #:unwind-for-type &unknown-client-locale))))))) + (format (current-error-port) + (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") + ((record-accessor &unknown-client-locale 'web-locale) error) + ((record-accessor &unknown-client-locale 'c-locale) error) + (error->str error)))) + (lambda () + (receive (response response-body user cause) + (call-with-values + (lambda () + (handler request request-body)) + (case-lambda + ((response response-body) + (values response response-body #f #f)) + ((response response-body user) + (values response response-body user #f)) + ((response response-body user cause) + (values response response-body user cause)))) + (let ((logging-port + (let ((response-code (response-code response))) + (if (>= response-code 400) + ;; That’s an error + (current-error-port) + (current-output-port))))) + (with-mutex logging-mutex + (format logging-port + (G_ "~a: ~s ~a ~s ~a\n") + (if user + (format #f (G_ "~a: ~a (~a)") + (date->string (time-utc->date (current-time))) + (uri->string user) + (request-ip-address request)) + (format #f (G_ "~a: ~a") + (date->string (time-utc->date (current-time))) + (request-ip-address request))) + (request-method request) + (uri-path (request-uri request)) + (response-code response) + (if cause + (string-append + (response-reason-phrase response) + " " + (format #f (G_ "(there was an error: ~a)") + (error->str cause))) + (response-reason-phrase response))))) + (return + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))) + ,@(response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))) + #:unwind? #t + #:unwind-for-type &unknown-client-locale)))))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. @@ -753,8 +768,6 @@ Rreleased ~a\n") (make-identity-provider server-name key-file subject encrypted-password jwks-uri authorization-endpoint-uri token-endpoint-uri - (make-jti-list) - #:current-time current-time #:http-get cache-http-get))) (run-server* (handler-with-log @@ -821,49 +834,45 @@ Rreleased ~a\n") (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n") token-endpoint-uri-sym) (exit 1)) - (let ((jti-list (make-jti-list))) - (let ((resource-handler - (make-resource-server - #:server-uri server-name - #:owner subject - #:authenticator - (if header - (begin - (set! header - (string->symbol - (string-downcase - (symbol->string header)))) - (lambda (request request-body) - (let ((value (assq-ref (request-headers request) header))) - (and value (string->uri value))))) - (make-authenticator - jti-list - #:server-uri server-name - #:http-get cache-http-get)) - #:http-get cache-http-get)) - (identity-provider-handler - (make-identity-provider - server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri - jti-list - #:current-time current-time - #:http-get cache-http-get))) - (create-root server-name subject) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source - (lambda (request request-body) - (let ((path (uri-path (request-uri request)))) - (if (or (equal? path "/.well-known/openid-configuration") - (equal? path (uri-path jwks-uri)) - (equal? path (uri-path authorization-endpoint-uri)) - (equal? path (uri-path token-endpoint-uri))) - (identity-provider-handler request request-body) - (resource-handler request request-body))))) - 'http - (list #:port port))))) + (let ((resource-handler + (make-resource-server + #:server-uri server-name + #:owner subject + #:authenticator + (if header + (begin + (set! header + (string->symbol + (string-downcase + (symbol->string header)))) + (lambda (request request-body) + (let ((value (assq-ref (request-headers request) header))) + (and value (string->uri value))))) + (make-authenticator + #:server-uri server-name + #:http-get cache-http-get)) + #:http-get cache-http-get)) + (identity-provider-handler + (make-identity-provider + server-name key-file subject encrypted-password jwks-uri + authorization-endpoint-uri token-endpoint-uri + #:http-get cache-http-get))) + (create-root server-name subject) + (run-server* + (handler-with-log + (option-ref options log-file-sym #f) + (option-ref options error-file-sym #f) + complete-corresponding-source + (lambda (request request-body) + (let ((path (uri-path (request-uri request)))) + (if (or (equal? path "/.well-known/openid-configuration") + (equal? path (uri-path jwks-uri)) + (equal? path (uri-path authorization-endpoint-uri)) + (equal? path (uri-path token-endpoint-uri))) + (identity-provider-handler request request-body) + (resource-handler request request-body))))) + 'http + (list #:port port)))) (else (format (current-error-port) (G_ "Unknown command ~s\n") command) diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm index 34b2f1b..e3fbf7c 100644 --- a/src/scm/webid-oidc/refresh-token.scm +++ b/src/scm/webid-oidc/refresh-token.scm @@ -18,36 +18,33 @@ #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (ice-9 optargs) #:use-module (ice-9 threads) - #:use-module (srfi srfi-19)) + #:use-module (srfi srfi-19) + #:export + ( + list-refresh-tokens + update-refresh-token-list + issue-refresh-token + with-refresh-token + remove-refresh-token + )) -(define-public (default-dir) - (let ((xdg-data-home (or - (getenv "XDG_DATA_HOME") - (format #f "~a/.local/share" - (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-data-home))) - -(define*-public (list-refresh-tokens - #:key - (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (list-refresh-tokens) (catch #t (lambda () - (with-input-from-file (format #f "~a/refresh-tokens.scm" dir) + (with-input-from-file (format #f "~a/refresh-tokens.scm" (p:data-home)) read)) (lambda errors '()))) +;; TODO: use stubs:atomically-update-file and remove that mutex. (define mutex (make-mutex)) -(define* (set-refresh-token-list list - #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (set-refresh-token-list list) + (define dir (p:data-home)) (define old-file (format #f "~a/refresh-tokens.scm" dir)) (define new-file (format #f "~a/refresh-tokens.scm~" dir)) (stubs:call-with-output-file* @@ -57,12 +54,11 @@ (close-port port))) (rename-file new-file old-file)) -(define*-public (update-refresh-token-list f - #:key (dir default-dir)) +(define (update-refresh-token-list f) (with-mutex mutex - (let ((old (list-refresh-tokens #:dir dir))) + (let ((old (list-refresh-tokens))) (let ((new (f old))) - (set-refresh-token-list new #:dir dir))))) + (set-refresh-token-list new))))) (define (remove sub aud) (lambda (old) @@ -90,20 +86,13 @@ (refresh_token . ,jti)) (remover old))))) -(define*-public (issue-refresh-token sub aud jkt - #:key - (dir default-dir)) +(define (issue-refresh-token sub aud jkt) (define jti (stubs:random 12)) - (update-refresh-token-list (insert sub aud jkt jti) - #:dir dir) + (update-refresh-token-list (insert sub aud jkt jti)) jti) -(define*-public (with-refresh-token refresh-token - key - f - #:key - (dir default-dir)) - (let ((list (list-refresh-tokens #:dir dir))) +(define (with-refresh-token refresh-token key f) + (let ((list (list-refresh-tokens))) (define (check list) (if (null? list) (raise-invalid-refresh-token refresh-token) @@ -121,7 +110,5 @@ (check tl)))))) (check list))) -(define*-public (remove-refresh-token sub aud - #:key - (dir default-dir)) - (update-refresh-token-list (remove sub aud) #:dir dir)) +(define (remove-refresh-token sub aud) + (update-refresh-token-list (remove sub aud))) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index a6c111e..14d8b81 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -21,12 +21,13 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc serve) - #:use-module (webid-oidc server create) - #:use-module (webid-oidc server read) - #:use-module (webid-oidc server update) - #:use-module (webid-oidc server delete) + #:use-module ((webid-oidc server create) #:prefix ldp:) + #:use-module ((webid-oidc server read) #:prefix ldp:) + #:use-module ((webid-oidc server update) #:prefix ldp:) + #:use-module ((webid-oidc server delete) #:prefix ldp:) #:use-module (webid-oidc server precondition) #:use-module (webid-oidc http-link) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (webid-oidc jti) #:use-module (webid-oidc access-token) @@ -51,8 +52,7 @@ (car (reverse (string-split text #\|))) out))) -(define*-public (make-authenticator jti-list - #:key +(define*-public (make-authenticator #:key (server-uri #f) (current-time current-time) (http-get http-get)) @@ -62,52 +62,45 @@ (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* ((lit-access-token (symbol->string (cadr authz))) - (access-token - (access-token-decode lit-access-token - #: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 #:access-token lit-access-token))) - (let ((subject (access-token-webid access-token)) - (issuer (access-token-iss access-token))) - (confirm-provider subject issuer #:http-get http-get) - subject))) - #:unwind? #t)))))) + (current-time ((p:current-date)))) + (parameterize ((p:current-date current-time)) ;; fix the date + (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* ((lit-access-token (symbol->string (cadr authz))) + (access-token + (access-token-decode lit-access-token + #:http-get http-get)) + (cnf/jkt (access-token-cnf/jkt access-token)) + (dpop-proof + (dpop-proof-decode + method full-uri + dpop cnf/jkt #:access-token lit-access-token))) + (let ((subject (access-token-webid access-token)) + (issuer (access-token-iss access-token))) + (confirm-provider subject issuer #:http-get http-get) + subject))) + #:unwind? #t))))))) (define (handle-errors f g) (call/ec @@ -175,171 +168,170 @@ (server-uri #f) (owner #f) (authenticator #f) - (current-time current-time) (http-get http-get)) (unless owner (error "The owner is not defined.")) (declare-link-header!) (unless authenticator (set! authenticator - (make-authenticator (make-jti-list) - #:server-uri server-uri - #:current-time current-time - #:http-get http-get))) + (make-authenticator + #:server-uri server-uri + #:http-get http-get))) (lambda (request request-body) - (let ((user (authenticator request request-body))) - (handle-errors - (lambda (return) - (let ((method (request-method request))) - (case method - ((GET HEAD OPTIONS) - (receive (headers content) - (read server-uri owner user - (uri-path (request-uri request)) - #:http-get http-get) - (let ((true-content-type - (car (assq-ref headers 'content-type))) - (other-headers - (filter - (lambda (h) - (not (eq? (car h) 'content-type))) - headers))) - (receive (negociated-content-type - negociated-content) - (convert (request-accept request #f) - server-uri - (uri-path (request-uri request)) - true-content-type - content) - (serve-get - return - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - negociated-content-type - negociated-content - (car (assq-ref headers 'etag)) - (cons `(content-type ,negociated-content-type) - other-headers) - user))))) - ((PUT) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (return - (build-response - #:headers - `((etag . (,(update server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - content-type - content - #:http-get http-get) - . #f)))) - "" - user))) - ((POST) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (let ((types - (map car - (filter - (lambda (link) - (equal? (assq-ref link 'rel) "type")) - (request-links request))))) + (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date + (let ((user (authenticator request request-body))) + (handle-errors + (lambda (return) + (let ((method (request-method request))) + (case method + ((GET HEAD OPTIONS) + (receive (headers content) + (ldp:read server-uri owner user + (uri-path (request-uri request)) + #:http-get http-get) + (let ((true-content-type + (car (assq-ref headers 'content-type))) + (other-headers + (filter + (lambda (h) + (not (eq? (car h) 'content-type))) + headers))) + (receive (negociated-content-type + negociated-content) + (convert (request-accept request #f) + server-uri + (uri-path (request-uri request)) + true-content-type + content) + (serve-get + return + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + negociated-content-type + negociated-content + (car (assq-ref headers 'etag)) + (cons `(content-type ,negociated-content-type) + other-headers) + user))))) + ((PUT) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) (return (build-response - #:code 201 #:reason-phrase "Created" #:headers - `((location . ,(create server-uri owner user - (uri-path (request-uri request)) - types - (assq-ref (request-headers request) 'slug) - content-type - content - #:http-get http-get)))) + `((etag . (,(ldp:update server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + content-type + content + #:http-get http-get) + . #f)))) "" - user)))) - ((DELETE) - (delete server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - #:http-get http-get) - (return - (build-response) - "" - user))))) - (lambda (return error) - (if (cannot-fetch-group? error) - (format (current-error-port) (G_ "Warning: ~a\n") - (error->str error)) - (cond - ((uri-slash-semantics-error? error) - (return - (build-response - #:code 301 - #:reason-phrase "Found" - #:headers - `((location - . ,(build-uri - (uri-scheme server-uri) - #:userinfo (uri-userinfo server-uri) - #:host (uri-host server-uri) - #:port (uri-port server-uri) - #:path (uri-slash-semantics-error-expected-path error))))) - #f - user)) - ((or (path-not-found? error) - (auxiliary-resource-absent? error) - (forbidden? error)) - (if user - ;; That’s a forbidden - (return - (build-response #:code 403 #:reason-phrase "Forbidden") - #f - user) - (return - (build-response #:code 401 #:reason-phrase "Unauthorized" - #:headers `((www-authenticate . ((DPoP))))) - #f - user))) - ((or (cannot-delete-root? error)) - (return - (build-response - #:code 405 - #:reason-phrase "Method Not Allowed") - #f - user)) - ((or (container-not-empty? error) - (incorrect-containment-triples? error) - (path-is-auxiliary? error)) - (return - (build-response - #:code 409 - #:reason-phrase "Conflict") - #f - user)) - ((unsupported-media-type? error) - (return - (build-response - #:code 415 - #:reason-phrase "Unsupported Media Type") - #f - user)) - ((precondition-failed? error) - (return - (build-response - #:code 412 - #:reason-phrase "Precondition Failed") - #f - user)) - ((not-acceptable? error) - (return - (build-response - #:code 406 - #:reason-phrase "Not Acceptable") - #f - user)) - (else - (raise-exception error))))))))) + user))) + ((POST) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) + (let ((types + (map car + (filter + (lambda (link) + (equal? (assq-ref link 'rel) "type")) + (request-links request))))) + (return + (build-response + #:code 201 #:reason-phrase "Created" + #:headers + `((location . ,(ldp:create server-uri owner user + (uri-path (request-uri request)) + types + (assq-ref (request-headers request) 'slug) + content-type + content + #:http-get http-get)))) + "" + user)))) + ((DELETE) + (ldp:delete server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + #:http-get http-get) + (return + (build-response) + "" + user))))) + (lambda (return error) + (if (cannot-fetch-group? error) + (format (current-error-port) (G_ "Warning: ~a\n") + (error->str error)) + (cond + ((uri-slash-semantics-error? error) + (return + (build-response + #:code 301 + #:reason-phrase "Found" + #:headers + `((location + . ,(build-uri + (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (uri-slash-semantics-error-expected-path error))))) + #f + user)) + ((or (path-not-found? error) + (auxiliary-resource-absent? error) + (forbidden? error)) + (if user + ;; That’s a forbidden + (return + (build-response #:code 403 #:reason-phrase "Forbidden") + #f + user) + (return + (build-response #:code 401 #:reason-phrase "Unauthorized" + #:headers `((www-authenticate . ((DPoP))))) + #f + user))) + ((or (cannot-delete-root? error)) + (return + (build-response + #:code 405 + #:reason-phrase "Method Not Allowed") + #f + user)) + ((or (container-not-empty? error) + (incorrect-containment-triples? error) + (path-is-auxiliary? error)) + (return + (build-response + #:code 409 + #:reason-phrase "Conflict") + #f + user)) + ((unsupported-media-type? error) + (return + (build-response + #:code 415 + #:reason-phrase "Unsupported Media Type") + #f + user)) + ((precondition-failed? error) + (return + (build-response + #:code 412 + #:reason-phrase "Precondition Failed") + #f + user)) + ((not-acceptable? error) + (return + (build-response + #:code 406 + #:reason-phrase "Not Acceptable") + #f + user)) + (else + (raise-exception error)))))))))) diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm index f9caba6..a1b05e3 100644 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -18,8 +18,8 @@ #: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 ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 i18n) @@ -36,9 +36,7 @@ (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)) @@ -50,9 +48,7 @@ (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.")) @@ -68,43 +64,46 @@ 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)))))))))))) + (apply throw key args)))))) + (request-time ((p:current-date)))) + (parameterize ((p:current-date request-time)) + ;; The time is now set for the duration of the request + (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))))))))))))) diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm index 29d8889..57c51dd 100644 --- a/src/scm/webid-oidc/server/resource/content.scm +++ b/src/scm/webid-oidc/server/resource/content.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (rnrs bytevectors) #:use-module (ice-9 exceptions) @@ -36,18 +37,18 @@ )) -(define (default-dir) - (string-append (refresh:default-dir) "/server")) - (define-class <content> () (content-type #:init-keyword #:content-type #:getter content-type) (contained #:init-keyword #:contained #:getter contained) (static-content #:init-keyword #:static-content #:getter static-content)) -(define (load-content session dir etag) +(define (load-content session etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (call-with-input-file (format #f "~a/content/~a/~a" dir first-char rest) + (call-with-input-file (format #f "~a/server/content/~a/~a" + (p:data-home) + first-char + rest) (lambda (port) (let ((properties (read port))) (set-port-encoding! port "ISO-8859-1") @@ -60,14 +61,14 @@ (hash-set! session etag ret) ret)))))) -(define (new-content session dir content-type contained static-content) +(define (new-content session content-type contained static-content) (when (string? static-content) (set! static-content (string->utf8 static-content))) (let ((etag (stubs:random 12))) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (stubs:mkdir-p (format #f "~a/content/~a" dir first-char)) - (let ((port (open (format #f "~a/content/~a/~a" dir first-char rest) + (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) + (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) (logior O_WRONLY O_CREAT O_EXCL)))) (write `((content-type . ,content-type) (contained . ,contained)) port) @@ -82,18 +83,16 @@ #:static-content static-content)) etag)))) -(define (delete-content dir etag) +(define (delete-content etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (delete-file (format #f "~a/content/~a/~a" dir first-char rest)))) + (delete-file (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest)))) -(define* (with-session f #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (with-session f) (let ((session (make-hash-table))) (define (do-load etag) (or (hash-ref session etag) - (load-content session dir etag))) + (load-content session etag))) (define (get-content-type etag) (content-type (do-load etag))) (define (get-contained etag) @@ -101,7 +100,7 @@ (define (get-static-content etag) (static-content (do-load etag))) (define (do-create content-type contained static-content) - (new-content session dir content-type contained static-content)) + (new-content session content-type contained static-content)) (define (do-delete etag) - (delete-content dir etag)) + (delete-content etag)) (f get-content-type get-contained get-static-content do-create do-delete))) diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index f1594bc..55c4274 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (rnrs bytevectors) #:use-module (ice-9 exceptions) @@ -47,17 +48,14 @@ )) -(define (default-dir) - (string-append (refresh:default-dir) "/server")) - (define (hash-path/lock path) (let ((h (stubs:hash 'SHA-256 path)) - (dir (default-dir))) + (dir (p:data-home))) (let ((first-char (substring h 0 1)) (rest (substring h 1))) (values - (format #f "~a/path/~a/~a" dir first-char rest) - (format #f "~a/path/~a/.lock" dir first-char))))) + (format #f "~a/server/path/~a/~a" dir first-char rest) + (format #f "~a/server/path/~a/.lock" dir first-char))))) (define (hash-path path) (receive (h lock) (hash-path/lock path) diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm index 0c6f0bc..08d15aa 100644 --- a/src/scm/webid-oidc/stubs.scm +++ b/src/scm/webid-oidc/stubs.scm @@ -17,6 +17,7 @@ (define-module (webid-oidc stubs) #:use-module (webid-oidc config) #:use-module (webid-oidc errors) + #:use-module (webid-oidc parameters) #:use-module (json)) (load-extension @@ -71,11 +72,16 @@ (lambda error (raise-unsupported-alg (cadr error))))) +(define (fix-random-init!) + (setenv "XDG_CACHE_HOME" (cache-home)) + (setenv "DISFLUID_APPLICATION_NAME" ".") + (random-init!)) + (export base64-encode (fix-base64-decode . base64-decode) random - random-init! + (fix-random-init! . random-init!) (fix-generate-key . generate-key) (fix-kty . kty) strip-key diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index 0aec4b8..aec9504 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -16,31 +16,23 @@ (define-module (webid-oidc testing) #:use-module (webid-oidc stubs) - #:use-module (webid-oidc errors)) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc parameters)) ;; This module is used only when running tests. (define-public (with-test-environment test-name f) - (let ((cache-dir (format #f "tests/~a.cache" test-name)) - (data-dir (format #f "tests/~a.home" test-name))) - (setenv "XDG_CACHE_HOME" cache-dir) - (setenv "XDG_DATA_HOME" data-dir) - (catch #t - (lambda () (mkdir cache-dir)) - (lambda err #t)) - (let ((pkg-cache-dir (format #f "~a/disfluid" cache-dir))) - (catch #t - (lambda () (mkdir pkg-cache-dir)) - (lambda err #t)) - (let ((seed-file-name (format #f "~a/seed" pkg-cache-dir))) - (with-output-to-file seed-file-name - (lambda () - (format #t "This is the initial seed for the random number generator")))))) (with-exception-handler (lambda (error) (format (current-error-port) "The test failed, because ~a.\n" (error->str error)) (raise-exception error)) (lambda () - (random-init!) - (f)))) + (parameterize ((data-home (format #f "tests/~a.home/disfluid" test-name)) + (cache-home (format #f "tests/~a.cache/disfluid" test-name))) + (call-with-output-file* + (format #f "~a/seed" (cache-home)) + (lambda (port) + (format port "This is the initial seed for the random number generator"))) + (random-init!) + (f))))) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 5a05945..7c4d41c 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -22,6 +22,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc access-token) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module (web client) @@ -76,116 +77,101 @@ thunk #:unwind? #t)))) -(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity jti-list - #:key - (refresh-token-dir refresh:default-dir) - (current-time current-time)) +(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity) (lambda* (request request-body) (try-handle-web-failure (lambda () (when (bytevector? request-body) (set! request-body (utf8->string request-body))) - (let ((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)) - (form-args - (if (and (request-content-type request) - (eq? (car (request-content-type request)) - 'application/x-www-form-urlencoded)) - (filter - (lambda (x) x) - (map (lambda (kv) - (let ((parsed - (list->vector - (map (lambda (x) - (uri-decode x #:decode-plus-to-space? #t)) - (string-split kv #\=))))) - (if (eq? (vector-length parsed) 2) - `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) - #f))) - (string-split request-body #\&))) - '())) - (method (request-method request)) - ;; Maybe we’re behind a reverse proxy, so the authority of - ;; (request-uri request) is meaningless. - (uri (build-uri (uri-scheme token-endpoint-uri) - #:userinfo (uri-userinfo token-endpoint-uri) - #:host (uri-host token-endpoint-uri) - #:port (uri-port token-endpoint-uri) - #:path (uri-path (request-uri request)) - #:query (uri-query (request-uri request))))) - (let ((grant-type (assoc-ref form-args "grant_type")) - (dpop (dpop-proof-decode - current-time jti-list method uri - (assq-ref (request-headers request) 'dpop) - (lambda (jkt) #t)))) - (unless (and grant-type (string? grant-type)) - (raise-unsupported-grant-type #f)) - (receive (webid client-id) - (case (string->symbol grant-type) - ((authorization_code) - (let ((code - (let ((str (assoc-ref form-args "code"))) - (unless str - (raise-no-authorization-code)) - (authorization-code-decode - current-time jti-list str jwk)))) - (values (authorization-code-webid code) - (authorization-code-client-id code)))) - ((refresh_token) - (let ((refresh-token (assoc-ref form-args "refresh_token"))) - (unless refresh-token - (raise-no-refresh-token)) - (refresh:with-refresh-token - refresh-token - (dpop-proof-jwk dpop) - values - #:dir refresh-token-dir))) - (else - (raise-unsupported-grant-type grant-type))) - (let* ((iat (time-second (date->time-utc current-time))) - (exp (+ iat validity))) - (let ((id-token - (issue-id-token - jwk - #:alg alg - #:webid (uri->string webid) - #:sub (uri->string webid) - #:iss (uri->string iss) - #:aud (uri->string client-id) - #:exp exp - #:iat iat)) - (access-token - (issue-access-token - jwk - #:alg alg - #:webid (uri->string webid) - #:iss (uri->string iss) - #:exp exp - #:iat iat - #:client-key (dpop-proof-jwk dpop) - #:client-id (uri->string client-id))) - (refresh-token - (if (equal? grant-type "refresh_token") - (assoc-ref form-args "refresh_token") - (refresh:issue-refresh-token webid client-id - (jkt (dpop-proof-jwk dpop)) - #:dir refresh-token-dir)))) - (values - (build-response #:headers '((content-type application/json) - (cache-control (no-cache no-store))) - #:port #f) - (stubs:scm->json-string - `((id_token . ,id-token) - (access_token . ,access-token) - (token_type . "DPoP") - (expires_in . ,validity) - (refresh_token . ,refresh-token))) - client-id - #f)))))))))) + (parameterize ((p:current-date ((p:current-date)))) + (let ((current-time ((p:current-date))) ;; thunk parameter + (form-args + (if (and (request-content-type request) + (eq? (car (request-content-type request)) + 'application/x-www-form-urlencoded)) + (filter + (lambda (x) x) + (map (lambda (kv) + (let ((parsed + (list->vector + (map (lambda (x) + (uri-decode x #:decode-plus-to-space? #t)) + (string-split kv #\=))))) + (if (eq? (vector-length parsed) 2) + `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) + #f))) + (string-split request-body #\&))) + '())) + (method (request-method request)) + ;; Maybe we’re behind a reverse proxy, so the authority of + ;; (request-uri request) is meaningless. + (uri (build-uri (uri-scheme token-endpoint-uri) + #:userinfo (uri-userinfo token-endpoint-uri) + #:host (uri-host token-endpoint-uri) + #:port (uri-port token-endpoint-uri) + #:path (uri-path (request-uri request)) + #:query (uri-query (request-uri request))))) + (let ((grant-type (assoc-ref form-args "grant_type")) + (dpop (dpop-proof-decode + method uri + (assq-ref (request-headers request) 'dpop) + (lambda (jkt) #t)))) + (unless (and grant-type (string? grant-type)) + (raise-unsupported-grant-type #f)) + (receive (webid client-id) + (case (string->symbol grant-type) + ((authorization_code) + (let ((code + (let ((str (assoc-ref form-args "code"))) + (unless str + (raise-no-authorization-code)) + (authorization-code-decode str jwk)))) + (values (authorization-code-webid code) + (authorization-code-client-id code)))) + ((refresh_token) + (let ((refresh-token (assoc-ref form-args "refresh_token"))) + (unless refresh-token + (raise-no-refresh-token)) + (refresh:with-refresh-token + refresh-token + (dpop-proof-jwk dpop) + values))) + (else + (raise-unsupported-grant-type grant-type))) + (let* ((iat (time-second (date->time-utc current-time))) + (exp (+ iat validity))) + (let ((id-token + (issue-id-token + jwk + #:alg alg + #:webid (uri->string webid) + #:sub (uri->string webid) + #:iss (uri->string iss) + #:aud (uri->string client-id) + #:validity 3600)) + (access-token + (issue-access-token + jwk + #:alg alg + #:webid (uri->string webid) + #:iss (uri->string iss) + #:validity 3600 + #:client-key (dpop-proof-jwk dpop) + #:client-id (uri->string client-id))) + (refresh-token + (if (equal? grant-type "refresh_token") + (assoc-ref form-args "refresh_token") + (refresh:issue-refresh-token webid client-id + (jkt (dpop-proof-jwk dpop)))))) + (values + (build-response #:headers '((content-type application/json) + (cache-control (no-cache no-store))) + #:port #f) + (stubs:scm->json-string + `((id_token . ,id-token) + (access_token . ,access-token) + (token_type . "DPoP") + (expires_in . ,validity) + (refresh_token . ,refresh-token))) + client-id + #f))))))))))) |