From f5f7d4e8253481e59ad89f7ec993c7739a47c81c Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Wed, 2 Dec 2020 09:31:05 +0100 Subject: Add the refresh token code --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/errors.scm | 34 +++++++++-- src/scm/webid-oidc/refresh-token.scm | 111 +++++++++++++++++++++++++++++++++++ src/scm/webid-oidc/testing.scm | 4 +- 4 files changed, 148 insertions(+), 7 deletions(-) create mode 100644 src/scm/webid-oidc/refresh-token.scm (limited to 'src') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 6736595..d18d5fc 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -11,7 +11,8 @@ dist_webidoidcmod_DATA += \ %reldir%/dpop-proof.scm \ %reldir%/fetch.scm \ %reldir%/client-manifest.scm \ - %reldir%/authorization-code.scm + %reldir%/authorization-code.scm \ + %reldir%/refresh-token.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -25,4 +26,5 @@ webidoidcgo_DATA += \ %reldir%/dpop-proof.go \ %reldir%/fetch.go \ %reldir%/client-manifest.go \ - %reldir%/authorization-code.go + %reldir%/authorization-code.go \ + %reldir%/refresh-token.go diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 879b23c..e8ab5af 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -687,6 +687,26 @@ (raise-exception ((record-constructor &cannot-encode-authorization-code) authorization-code key cause))) +(define-public &invalid-refresh-token + (make-exception-type + '&invalid-refresh-token + &external-error + '(refresh-token))) + +(define-public (raise-invalid-refresh-token refresh-token) + (raise-exception + ((record-constructor &invalid-refresh-token) refresh-token))) + +(define-public &invalid-key-for-refresh-token + (make-exception-type + '&invalid-key-for-refresh-token + &external-error + '(key jkt))) + +(define-public (raise-invalid-key-for-refresh-token key jkt) + (raise-exception + ((record-constructor &invalid-key-for-refresh-token) key jkt))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -956,16 +976,22 @@ ((¬-an-authorization-code-payload) (format #f (G_ "~s is not an authorization code payload (because ~a)") (get 'value) (recurse (get 'cause)))) - ((&authorization-code-expired) - (format #f (G_ "the current time is ~a, and the authorization code expired at ~a") - (time-second (date->time-utc (get 'current-time))) - (time-second (date->time-utc (get 'exp))))) + ((&authorization-code-expired) + (format #f (G_ "the current time is ~a, and the authorization code expired at ~a") + (time-second (date->time-utc (get 'current-time))) + (time-second (date->time-utc (get 'exp))))) ((&cannot-decode-authorization-code) (format #f (G_ "I cannot decode ~s as an authorization code (because ~a)") (get 'value) (recurse (get 'cause)))) ((&cannot-encode-authorization-code) (format #f (G_ "I cannot encode ~s as an authorization code (because ~a)") (get 'value) (recurse (get 'cause)))) + ((&invalid-refresh-token) + (format #f (G_ "there is no such refresh token as ~s") + (get 'refresh-token))) + ((&invalid-key-for-refresh-token) + (format #f (G_ "the refresh token is bound to a key confirmed as ~s, but it is used with key ~s") + (get 'jkt) (get 'key))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm new file mode 100644 index 0000000..d2a7da6 --- /dev/null +++ b/src/scm/webid-oidc/refresh-token.scm @@ -0,0 +1,111 @@ +(define-module (webid-oidc refresh-token) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (webid-oidc jwk) + #:use-module (web uri) + #:use-module (ice-9 optargs) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-19)) + +(define-public (default-dir) + (let ((xdg-data-home (or + (getenv "XDG_DATA_HOME") + (format #f "~a/.local/share" + (getenv "HOME"))))) + (format #f "~a/webid-oidc" xdg-data-home))) + +(define*-public (list-refresh-tokens + #:key + (dir default-dir)) + (when (thunk? dir) + (set! dir (dir))) + (catch #t + (lambda () + (with-input-from-file (format #f "~a/refresh-tokens.scm" dir) + read)) + (lambda errors + '()))) + +(define mutex (make-mutex)) + +(define* (set-refresh-token-list list + #:key (dir default-dir)) + (when (thunk? dir) + (set! dir (dir))) + (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* + new-file + (lambda (port) + (write list port) + (close-port port))) + (rename-file new-file old-file)) + +(define*-public (update-refresh-token-list f + #:key (dir default-dir)) + (with-mutex mutex + (let ((old (list-refresh-tokens #:dir dir))) + (let ((new (f old))) + (set-refresh-token-list new #:dir dir))))) + +(define (remove sub aud) + (lambda (old) + (filter (lambda (o) + (not (and (equal? (assq-ref o 'sub) + (uri->string sub)) + (equal? (assq-ref o 'aud) + (uri->string aud))))) + old))) + +(define (keep-n n list) + (cond + ((<= n 0) '()) + ((null? list) '()) + (else (cons (car list) (keep-n (- n 1) (cdr list)))))) + +(define (insert sub aud jkt jti) + (define remover (remove sub aud)) + (lambda (old) + (keep-n + 20 + (cons `((sub . ,(uri->string sub)) + (aud . ,(uri->string aud)) + (jkt . ,jkt) + (refresh_token . ,jti)) + (remover old))))) + +(define*-public (issue-refresh-token sub aud jkt + #:key + (dir default-dir)) + (define jti (stubs:random 12)) + (update-refresh-token-list (insert sub aud jkt jti) + #:dir dir) + jti) + +(define*-public (with-refresh-token refresh-token + key + f + #:key + (dir default-dir)) + (let ((list (list-refresh-tokens #:dir dir))) + (define (check list) + (if (null? list) + (raise-invalid-refresh-token refresh-token) + (let ((hd (car list)) + (tl (cdr list))) + (let ((sub (string->uri (assq-ref hd 'sub))) + (aud (string->uri (assq-ref hd 'aud))) + (cnf/jkt (assq-ref hd 'jkt)) + (the-refresh-token (assq-ref hd 'refresh_token))) + (if (string=? refresh-token the-refresh-token) + (begin + (unless (equal? (jkt key) cnf/jkt) + (raise-invalid-key-for-refresh-token key cnf/jkt)) + (f sub aud)) + (check tl)))))) + (check list))) + +(define*-public (remove-refresh-token sub aud + #:key + (dir default-dir)) + (update-refresh-token-list (remove sub aud) #:dir dir)) diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index d4b7f4d..aecb2a3 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -5,8 +5,10 @@ ;; 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))) + (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)) -- cgit v1.2.3