From e910b3ba2ded990a5193f7ea0cfad525332e4171 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 20 Sep 2021 11:25:29 +0200 Subject: JWS: use GOOPS --- src/scm/webid-oidc/authorization-code.scm | 255 +++++++++--------------------- 1 file changed, 79 insertions(+), 176 deletions(-) (limited to 'src/scm/webid-oidc/authorization-code.scm') diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 1481b2c..13b7ac4 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -26,7 +26,18 @@ #:use-module (webid-oidc web-i18n) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (oop goops) #:declarative? #t + #:re-export + ( + alg iat exp nonce + token->jwt + decode + encode + issue + ) #:export ( @@ -34,18 +45,7 @@ make-invalid-authorization-code invalid-authorization-code? - the-authorization-code - authorization-code? - - authorization-code-alg - - authorization-code-webid - authorization-code-client-id - authorization-code-jti - authorization-code-exp - - authorization-code-decode - issue-authorization-code + webid client-id )) (define-exception-type @@ -54,171 +54,74 @@ make-invalid-authorization-code invalid-authorization-code?) -(define (the-authorization-code x) - (with-exception-handler - (lambda (error) - (let ((final-message - (cond - ((invalid-jws? error) - (if (exception-with-message? error) - (format #f (G_ "this is not an authorization code, because it is not even a JWS: ~a") - (exception-message error)) - (format #f (G_ "this is not an authorization code, because it is not even a JWS")))) - (else - (if (exception-with-message? error) - (format #f (G_ "this is not an authorization code: ~a") - (exception-message error)) - (format #f (G_ "this is not an authorization code"))))))) - (raise-exception - (make-exception - (make-invalid-authorization-code) - (make-exception-with-message final-message) - error)))) - (lambda () - (match (the-jws x) - ((header . payload) - (let examine-payload ((payload payload) - (webid #f) - (client-id #f) - (jti #f) - (exp #f) - (other-fields '())) - (match payload - (() - (unless (and webid client-id jti exp) - (fail (format #f (G_ "the payload is missing ~s") - `(,@(if webid '() '("webid")) - ,@(if client-id '() '("client_id")) - ,@(if jti '() '("jti")) - ,@(if exp '() '("exp")))))) - `(,header - . ((webid . ,(uri->string webid)) - (client_id . ,(uri->string client-id)) - (jti . ,jti) - (exp . ,(time-second (date->time-utc exp))) - ,@(reverse other-fields)))) - ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) - (examine-payload payload - (or webid webid-given) - client-id jti exp other-fields)) - ((('webid . infringing) payload ...) - (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") - infringing))) - ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...) - (examine-payload payload webid - (or client-id client-id-given) - jti exp other-fields)) - ((('client_id . infringing) payload ...) - (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given") - infringing))) - ((('jti . (? string? jti-given)) payload ...) - (examine-payload payload webid client-id - (or jti jti-given) - exp other-fields)) - ((('jti . invalid) payload ...) - (fail (format #f (G_ "the \"jti\" field should be a string, ~s is given") - invalid))) - ((('exp . (? (lambda (x) (and (integer? x) (>= x 0))) exp-given)) payload ...) - (examine-payload payload webid client-id jti - (or exp (time-utc->date (make-time time-utc 0 exp-given))) - other-fields)) - ((('exp . infringing) payload ...) - (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") - infringing))) - ((field payload ...) - (examine-payload payload webid client-id jti exp `(,field ,@other-fields)))))) - (else - (scm-error 'wrong-type-arg "the-authorization-code" - "expected a pair of lists" - '() - (list x))))))) - -(define (authorization-code? x) - (false-if-exception (the-authorization-code x))) +(define-class () + (webid #:init-keyword #:webid #:accessor webid) + (client-id #:init-keyword #:client-id #:accessor client-id)) -(define (authorization-code-alg x) - (match (the-authorization-code x) - ((header . _) - (string->symbol (assq-ref header 'alg))))) - -(define (authorization-code-webid x) - (match (the-authorization-code x) - ((_ . payload) - (string->uri (assq-ref payload 'webid))))) - -(define (authorization-code-client-id x) - (match (the-authorization-code x) - ((_ . payload) - (string->uri (assq-ref payload 'client_id))))) - -(define (authorization-code-jti x) - (match (the-authorization-code x) - ((_ . payload) - (assq-ref payload 'jti)))) - -(define (authorization-code-exp x) - (match (the-authorization-code x) - ((_ . payload) - (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp)))))) - -(define (authorization-code-decode str jwk) - (parameterize ((p:current-date - (time-second (date->time-utc ((p:current-date)))))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the authorization code is invalid: ~a") - (exception-message error)) - (format #f (G_ "the authorization code is invalid"))))) - (raise-exception - (make-exception - (make-invalid-authorization-code) - (make-exception-with-message final-message) - error)))) - (lambda () - (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) - (let ((exp (authorization-code-exp code)) - (current-date ((p:current-date)))) - (let ((exp-s (time-second (date->time-utc exp))) - (current-s (time-second (date->time-utc current-date)))) - (when (>= current-s exp-s) - (let ((final-message - (format #f (G_ "the authorization expired ~a, which is in the past (from ~a)") - (date->string exp) - (date->string current-date)))) - (raise-exception - (make-exception - (make-expired exp current-date) - (make-exception-with-message final-message))))) - (jti-check (authorization-code-jti code) - (- exp-s current-s)) - code))))))) - -(define (authorization-code-encode authorization-code key) +(define-method (initialize (token ) initargs) (with-exception-handler (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot encode the authorization code: ~a") - (exception-message error)) - (format #f (G_ "cannot encode the authorization code"))))) - (raise-exception - (make-exception-with-message final-message)))) + (raise-exception + (make-exception + (make-invalid-authorization-code) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "invalid authorization code: ~a") + (exception-message error)) + (G_ "invalid authorization code"))) + error))) (lambda () - (jws-encode authorization-code key)))) - -(define* (issue-authorization-code issuer-key - #:key - (validity 120) - webid - client-id) - (let* ((iat (time-second (date->time-utc ((p:current-date))))) - (exp (+ iat validity))) - (authorization-code-encode - `(((alg . ,(symbol->string (alg issuer-key)))) - . ((webid . ,(uri->string webid)) - (client_id . ,(uri->string client-id)) - (exp . ,exp) - (jti . ,(stubs:random 12)))) - issuer-key))) + (next-method) + (let-keywords + initargs #t + ((webid #f) + (client-id #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((webid webid) + (client-id client-id) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? webid) + (do-initialize (string->uri webid) client-id jwt-header jwt-payload)) + ((string? client-id) + (do-initialize webid (string->uri client-id) jwt-header jwt-payload)) + ((and webid client-id) + (unless (uri? webid) + (scm-error 'wrong-type-arg "make" + (G_ "#:webid should be an URI") + '() + (list webid))) + (unless (uri? client-id) + (scm-error 'wrong-type-arg "make" + (G_ "#:client-id should be a string") + '() + (list client-id))) + (slot-set! token 'webid webid) + (slot-set! token 'client-id client-id)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'webid) + (assq-ref jwt-payload 'client_id) + #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making an authorization code either its required fields (#:webid and #:client-id) or (#:jwt-header and #:jwt-payload) should be passed"))))))))))) + +(define-method (token->jwt (token )) + (receive (base-header base-payload) + (next-method) + (values + base-header + `((webid . ,(uri->string (webid token))) + (client_id . ,(uri->string (client-id token))) + ,@base-payload)))) + +(define-method (lookup-keys (token ) args) + (let-keywords + args #f + ((issuer-key #f)) + issuer-key)) -- cgit v1.2.3