From 680bce0098fa722fd7f8385b11ea5b065ff270c5 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 1 Dec 2020 19:46:24 +0100 Subject: Add an authorization code data structure --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/authorization-code.scm | 151 ++++++++++++++++++++++++++++++ src/scm/webid-oidc/errors.scm | 87 +++++++++++++++++ 3 files changed, 242 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/authorization-code.scm (limited to 'src/scm') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 709eb1b..6736595 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -10,7 +10,8 @@ dist_webidoidcmod_DATA += \ %reldir%/jti.scm \ %reldir%/dpop-proof.scm \ %reldir%/fetch.scm \ - %reldir%/client-manifest.scm + %reldir%/client-manifest.scm \ + %reldir%/authorization-code.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -23,4 +24,5 @@ webidoidcgo_DATA += \ %reldir%/jti.go \ %reldir%/dpop-proof.go \ %reldir%/fetch.go \ - %reldir%/client-manifest.go + %reldir%/client-manifest.go \ + %reldir%/authorization-code.go diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm new file mode 100644 index 0000000..93db73c --- /dev/null +++ b/src/scm/webid-oidc/authorization-code.scm @@ -0,0 +1,151 @@ +(define-module (webid-oidc authorization-code) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc jti) + #:use-module (web uri) + #:use-module (srfi srfi-19)) + +(define-public (the-authorization-code-header x) + (with-exception-handler + (lambda (error) + (raise-not-an-authorization-code-header x error)) + (lambda () + (the-jws-header x)))) + +(define-public (authorization-code-header? x) + (false-if-exception + (and (the-authorization-code-header x) #t))) + +(define-public (the-authorization-code-payload x) + (with-exception-handler + (lambda (error) + (raise-not-an-authorization-code-payload x error)) + (lambda () + (let ((x (the-jws-payload x))) + (let ((exp (assq-ref x 'exp)) + (jti (assq-ref x 'jti)) + (webid (assq-ref x 'webid)) + (client-id (assq-ref x 'client_id))) + (unless (integer? exp) + (raise-incorrect-exp-field exp)) + (unless (string? jti) + (raise-incorrect-jti-field jti)) + (unless (and (string? webid) (string->uri webid)) + (raise-incorrect-webid-field webid)) + (unless (and (string? client-id) (string->uri client-id)) + (raise-incorrect-client-id-field client-id)) + x))))) + +(define-public (authorization-code-payload? x) + (false-if-exception + (and (the-authorization-code-apayload x) #t))) + +(define-public (the-authorization-code x) + (with-exception-handler + (lambda (error) + (raise-not-an-authorization-code x error)) + (lambda () + (cons (the-authorization-code-header (car x)) + (the-authorization-code-payload (cdr x)))))) + +(define-public (authorization-code? x) + (false-if-exception + (and (the-authorization-code x) #t))) + +(define-public (make-authorization-code header payload) + (the-authorization-code (cons header payload))) + +(define-public (make-authorization-code-header alg) + (when (symbol? alg) + (set! alg (symbol->string alg))) + (the-authorization-code-header + `((alg . ,alg)))) + +(define-public (make-authorization-code-payload exp jti sub aud) + (when (date? exp) + (set! exp (date->time-utc exp))) + (when (time? exp) + (set! exp (time-second exp))) + (when (uri? sub) + (set! sub (uri->string sub))) + (when (uri? aud) + (set! aud (uri->string aud))) + (the-authorization-code-payload + `((exp . ,exp) + (jti . ,jti) + (webid . ,sub) + (client_id . ,aud)))) + +(define-public (authorization-code-header code) + (car (the-authorization-code code))) + +(define-public (authorization-code-payload code) + (cdr (the-authorization-code code))) + +(define-public (authorization-code-alg code) + (when (authorization-code? code) + (set! code (authorization-code-header code))) + (jws-alg (the-authorization-code-header code))) + +(define-public (authorization-code-exp code) + (when (authorization-code? code) + (set! code (authorization-code-payload code))) + (time-utc->date + (make-time time-utc 0 (assq-ref + (the-authorization-code-payload code) + 'exp)))) + +(define-public (authorization-code-jti code) + (when (authorization-code? code) + (set! code (authorization-code-payload code))) + (assq-ref (the-authorization-code-payload code) 'jti)) + +(define-public (authorization-code-webid code) + (when (authorization-code? code) + (set! code (authorization-code-payload code))) + (string->uri + (assq-ref (the-authorization-code-payload code) 'webid))) + +(define-public (authorization-code-client-id code) + (when (authorization-code? code) + (set! code (authorization-code-payload code))) + (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 (dpop-proof-jti decoded) error)) + (lambda () + (error "the jti-check function returned #f")))) + code))))) + +(define-public (authorization-code-encode authorization-code key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-authorization-code authorization-code key error)) + (lambda () + (jws-encode authorization-code key)))) + +(define-public (issue-authorization-code alg jwk exp sub aud) + (authorization-code-encode + (make-authorization-code + (make-authorization-code-header alg) + (make-authorization-code-payload exp (stubs:random 12) sub aud)) + jwk)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index b92c897..3e5495d 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -619,6 +619,74 @@ (raise-exception ((record-constructor &cannot-fetch-client-manifest) id cause))) +(define-public ¬-an-authorization-code + (make-exception-type + '¬-an-authorization-code + &external-error + '(value cause))) + +(define-public (raise-not-an-authorization-code value cause) + (raise-exception + ((record-constructor ¬-an-authorization-code) value cause))) + +(define-public ¬-an-authorization-code-header + (make-exception-type + '¬-an-authorization-code-header + &external-error + '(value cause))) + +(define-public (raise-not-an-authorization-code-header value cause) + (raise-exception + ((record-constructor ¬-an-authorization-code-header) value cause))) + +(define-public ¬-an-authorization-code-payload + (make-exception-type + '¬-an-authorization-code-payload + &external-error + '(value cause))) + +(define-public (raise-not-an-authorization-code-payload value cause) + (raise-exception + ((record-constructor ¬-an-authorization-code-payload) value cause))) + +(define-public &authorization-code-expired + (make-exception-type + '&authorization-code-expired + &external-error + '(exp current-time))) + +(define-public (raise-authorization-code-expired exp current-time) + (when (integer? exp) + (set! exp (make-time time-utc 0 exp))) + (when (time? exp) + (set! exp (time-utc->date exp))) + (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))) + (raise-exception + ((record-constructor &authorization-code-expired) exp current-time))) + +(define-public &cannot-decode-authorization-code + (make-exception-type + '&cannot-decode-authorization-code + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-authorization-code value cause) + (raise-exception + ((record-constructor &cannot-decode-authorization-code) value cause))) + +(define-public &cannot-encode-authorization-code + (make-exception-type + '&cannot-encode-authorization-code + &external-error + '(authorization-code key cause))) + +(define-public (raise-cannot-encode-authorization-code authorization-code key cause) + (raise-exception + ((record-constructor &cannot-encode-authorization-code) authorization-code key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -879,6 +947,25 @@ ((&cannot-fetch-client-manifest) (format #f (G_ "I could not fetch the client manifest of ~a (because ~a)") (uri->string (get 'id)) (recurse (get 'cause)))) + ((¬-an-authorization-code) + (format #f (G_ "~s is not an authorization code (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-an-authorization-code-header) + (format #f (G_ "~s is not an authorization code header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-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))))) + ((&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)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) -- cgit v1.2.3