diff options
Diffstat (limited to 'src/scm/webid-oidc/refresh-token.scm')
-rw-r--r-- | src/scm/webid-oidc/refresh-token.scm | 206 |
1 files changed, 142 insertions, 64 deletions
diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm index e3fbf7c..14d7361 100644 --- a/src/scm/webid-oidc/refresh-token.scm +++ b/src/scm/webid-oidc/refresh-token.scm @@ -18,13 +18,33 @@ #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jwk) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (ice-9 optargs) #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (sxml simple) + #:use-module (sxml match) + #:declarative? #t #:export ( + <refresh-token> + make-refresh-token + refresh-token? + refresh-token-sub + refresh-token-aud + refresh-token-jkt + refresh-token-refresh-token + + &invalid-refresh-token + make-invalid-refresh-token + invalid-refresh-token? + list-refresh-tokens update-refresh-token-list issue-refresh-token @@ -32,83 +52,141 @@ remove-refresh-token )) +(define-exception-type + &invalid-refresh-token + &external-error + make-invalid-refresh-token + invalid-refresh-token?) + +(define-record-type <refresh-token> + (make-refresh-token sub aud jkt refresh-token) + refresh-token? + (sub refresh-token-sub) + (aud refresh-token-aud) + (jkt refresh-token-jkt) + (refresh-token refresh-token-refresh-token)) + (define (list-refresh-tokens) - (catch #t - (lambda () - (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) - (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* - new-file - (lambda (port) - (write list port) - (close-port port))) - (rename-file new-file old-file)) + (let generate-list + ((content + (catch #t + (lambda () + (call-with-input-file (format #f "~a/refresh-tokens.xml" (p:data-home)) + (cute xml->sxml <> + #:namespaces '((disfluid + . "https://disfluid.planete-kraus.eu/refresh-token/v1"))))) + (lambda error + '(*TOP* (disfluid:refresh-tokens))))) + (parsed-refresh-tokens '())) + (sxml-match + content + ((*TOP* (disfluid:refresh-tokens)) + (reverse parsed-refresh-tokens)) + ((*TOP* (disfluid:refresh-tokens + (disfluid:refresh-token + (@ (sub ,subject) + (aud ,audience) + (jkt ,jkt) + (refresh-token ,refresh-token))) + ,other-refresh-tokens ...)) + (let ((content + `(*TOP* + (disfluid:refresh-tokens + ,@other-refresh-tokens))) + (next-refresh-token + (make-refresh-token (string->uri subject) + (string->uri audience) + jkt + refresh-token))) + (generate-list content + `(,next-refresh-token + ,@parsed-refresh-tokens))))))) -(define (update-refresh-token-list f) - (with-mutex mutex - (let ((old (list-refresh-tokens))) - (let ((new (f old))) - (set-refresh-token-list new))))) +(define (update-refresh-token-list transformer) + (stubs:atomically-update-file + (format #f "~a/refresh-tokens.xml" (p:data-home)) + (format #f "~a/refresh-tokens.xml.lock" (p:data-home)) + (lambda (port) + (let* ((old-refresh-tokens (list-refresh-tokens)) + (new-refresh-tokens (transformer old-refresh-tokens))) + (chmod port #o600) + (sxml->xml + `(*TOP* + (refresh-tokens + (@ (xmlns "https://disfluid.planete-kraus.eu/refresh-token/v1")) + ,@(map + (match-lambda + (($ <refresh-token> + (= uri->string subject) + (= uri->string audience) + jkt + refresh-token) + `(refresh-token + (@ (sub ,subject) + (aud ,audience) + (jkt ,jkt) + (refresh-token ,refresh-token))))) + new-refresh-tokens))) + port))))) (define (remove sub aud) + (cute filter + (match-lambda + (($ <refresh-token> + (? (cute equal? <> sub) _) + (? (cute equal? <> aud) _) + _ _) + #f) + (else #t)) + <>)) + +(define (keep-n n) (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)))))) + (let start-at ((i 0) (data old) (kept '())) + (match data + (() (reverse kept)) + ((saved data ...) + (if (>= i n) + (reverse kept) + (start-at (1+ i) data `(,saved ,@kept)))))))) (define (insert sub aud jkt jti) (define remover (remove sub aud)) + (define truncator (keep-n 20)) (lambda (old) - (keep-n - 20 - (cons `((sub . ,(uri->string sub)) - (aud . ,(uri->string aud)) - (jkt . ,jkt) - (refresh_token . ,jti)) - (remover old))))) + (truncator + `(,(make-refresh-token sub aud jkt jti) + ,@(remover old))))) (define (issue-refresh-token sub aud jkt) - (define jti (stubs:random 12)) - (update-refresh-token-list (insert sub aud jkt jti)) - jti) + (let ((jti (stubs:random 12))) + (update-refresh-token-list (insert sub aud jkt jti)) + jti)) (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) - (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))) + (let search ((tokens (list-refresh-tokens))) + (match tokens + (() + (let ((final-message + (format #f (G_ "the refresh token does not exist")))) + (raise-exception + (make-exception + (make-invalid-refresh-token) + (make-exception-with-message final-message))))) + ((($ <refresh-token> (? uri? sub) (? uri? aud) (? string? the-jkt) (? string? the-rft)) + tokens ...) + (if (equal? refresh-token the-rft) + (begin + (unless (equal? (jkt key) the-jkt) + (let ((final-message + (format #f (G_ "the refresh token is bound to key ~s, which is not that one") + the-jkt))) + (raise-exception + (make-exception + (make-invalid-refresh-token) + (make-exception-with-message final-message))))) + (f sub aud)) + (search tokens)))))) (define (remove-refresh-token sub aud) (update-refresh-token-list (remove sub aud))) |