From 34238b636411ac230f473b99f8a8e978711a9228 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Wed, 2 Dec 2020 09:58:55 +0100 Subject: Parse and issue OIDC ID tokens --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/errors.scm | 95 +++++++++++++++++ src/scm/webid-oidc/oidc-id-token.scm | 201 +++++++++++++++++++++++++++++++++++ 3 files changed, 300 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/oidc-id-token.scm (limited to 'src') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index d18d5fc..56b50ec 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -12,7 +12,8 @@ dist_webidoidcmod_DATA += \ %reldir%/fetch.scm \ %reldir%/client-manifest.scm \ %reldir%/authorization-code.scm \ - %reldir%/refresh-token.scm + %reldir%/refresh-token.scm \ + %reldir%/oidc-id-token.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -27,4 +28,5 @@ webidoidcgo_DATA += \ %reldir%/fetch.go \ %reldir%/client-manifest.go \ %reldir%/authorization-code.go \ - %reldir%/refresh-token.go + %reldir%/refresh-token.go \ + %reldir%/oidc-id-token.go diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index e8ab5af..b0e9a19 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -249,6 +249,16 @@ (raise-exception ((record-constructor &incorrect-webid-field) value))) +(define-public &incorrect-sub-field + (make-exception-type + '&incorrect-sub-field + &external-error + '(value))) + +(define-public (raise-incorrect-sub-field value) + (raise-exception + ((record-constructor &incorrect-sub-field) value))) + (define-public &incorrect-iss-field (make-exception-type '&incorrect-iss-field @@ -349,6 +359,16 @@ (raise-exception ((record-constructor &incorrect-jti-field) value))) +(define-public &incorrect-nonce-field + (make-exception-type + '&incorrect-nonce-field + &external-error + '(value))) + +(define-public (raise-incorrect-nonce-field value) + (raise-exception + ((record-constructor &incorrect-nonce-field) value))) + (define-public &incorrect-htm-field (make-exception-type '&incorrect-htm-field @@ -707,6 +727,56 @@ (raise-exception ((record-constructor &invalid-key-for-refresh-token) key jkt))) +(define-public ¬-an-id-token + (make-exception-type + '¬-an-id-token + &external-error + '(value cause))) + +(define-public (raise-not-an-id-token value cause) + (raise-exception + ((record-constructor ¬-an-id-token) value cause))) + +(define-public ¬-an-id-token-header + (make-exception-type + '¬-an-id-token-header + &external-error + '(value cause))) + +(define-public (raise-not-an-id-token-header value cause) + (raise-exception + ((record-constructor ¬-an-id-token-header) value cause))) + +(define-public ¬-an-id-token-payload + (make-exception-type + '¬-an-id-token-payload + &external-error + '(value cause))) + +(define-public (raise-not-an-id-token-payload value cause) + (raise-exception + ((record-constructor ¬-an-id-token-payload) value cause))) + +(define-public &cannot-decode-id-token + (make-exception-type + '&cannot-decode-id-token + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-id-token value cause) + (raise-exception + ((record-constructor &cannot-decode-id-token) value cause))) + +(define-public &cannot-encode-id-token + (make-exception-type + '&cannot-encode-id-token + &external-error + '(id-token key cause))) + +(define-public (raise-cannot-encode-id-token id-token key cause) + (raise-exception + ((record-constructor &cannot-encode-id-token) id-token key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -810,6 +880,11 @@ (if value (format #f (G_ "the webid field is incorrect: ~s") value) (format #f (G_ "the webid field is missing"))))) + ((&incorrect-sub-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the sub field is incorrect: ~s") value) + (format #f (G_ "the sub field is missing"))))) ((&incorrect-iss-field) (let ((value (get 'value))) (if value @@ -861,6 +936,11 @@ (if value (format #f (G_ "the jti field is incorrect: ~s") value) (format #f (G_ "the jti field is missing"))))) + ((&incorrect-nonce-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the nonce field is incorrect: ~s") value) + (format #f (G_ "the nonce field is missing"))))) ((&incorrect-htm-field) (let ((value (get 'value))) (if value @@ -992,6 +1072,21 @@ ((&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))) + ((&cannot-decode-id-token) + (format #f (G_ "I cannot decode ~s as an ID token (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-id-token) + (format #f (G_ "I cannot encode ~s as an ID token (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-an-id-token) + (format #f (G_ "~s is not an ID token (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-an-id-token-header) + (format #f (G_ "~s is not an ID token header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-an-id-token-payload) + (format #f (G_ "~s is not an ID token payload (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm new file mode 100644 index 0000000..18ac124 --- /dev/null +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -0,0 +1,201 @@ +(define-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc oidc-configuration) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc jti) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web uri) + #:use-module (web client) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-19)) + +(define-public (the-id-token-header x) + (with-exception-handler + (lambda (error) + (raise-not-an-id-token-header x error)) + (lambda () + (the-jws-header x)))) + +(define-public (id-token-header? x) + (false-if-exception + (and (the-id-token-header x) #t))) + +(define-public (the-id-token-payload x) + (with-exception-handler + (lambda (error) + (raise-not-an-id-token-payload x error)) + (lambda () + (let ((x (the-jws-payload x))) + (let ((webid (assq-ref x 'webid)) + (iss (assq-ref x 'iss)) + (sub (assq-ref x 'sub)) + (aud (assq-ref x 'aud)) + (nonce (assq-ref x 'nonce)) + (iat (assq-ref x 'iat)) + (exp (assq-ref x 'exp))) + (unless (and webid (string? webid) (string->uri webid)) + (raise-incorrect-webid-field webid)) + (unless (and iss (string? iss) (string->uri iss)) + (raise-incorrect-iss-field iss)) + (unless (string? sub) + (raise-incorrect-sub-field sub)) + (unless (and aud (string? aud) (string->uri aud)) + (raise-incorrect-aud-field aud)) + (unless (string? nonce) + (raise-incorrect-nonce-field nonce)) + (unless (integer? iat) + (raise-incorrect-iat-field iat)) + (unless (and (integer? exp) (>= exp iat)) + (raise-incorrect-exp-field exp)) + x))))) + +(define-public (id-token-payload? x) + (false-if-exception + (and (the-id-token-header x) #t))) + +(define-public (the-id-token x) + (with-exception-handler + (lambda (cause) + (raise-not-an-id-token x cause)) + (lambda () + (cons (the-id-token-header (car x)) + (the-id-token-payload (cdr x)))))) + +(define-public (id-token? x) + (false-if-exception + (and (the-id-token x) #t))) + +(define-public (make-id-token header payload) + (the-id-token + (cons header payload))) + +(define-public (make-id-token-payload webid iss sub aud nonce exp iat) + (when (date? exp) + (set! exp (date->time-utc exp))) + (when (time? exp) + (set! exp (time-second exp))) + (when (date? iat) + (set! iat (date->time-utc iat))) + (when (time? iat) + (set! iat (time-second iat))) + (when (uri? webid) + (set! webid (uri->string webid))) + (when (uri? iss) + (set! iss (uri->string iss))) + (when (uri? aud) + (set! aud (uri->string aud))) + (the-id-token-payload + `((webid . ,webid) + (iss . ,iss) + (sub . ,sub) + (aud . ,aud) + (nonce . ,nonce) + (exp . ,exp) + (iat . ,iat)))) + +(define-public (id-token-header code) + (car (the-id-token code))) + +(define-public (id-token-payload code) + (cdr (the-id-token code))) + +(define-public (id-token-alg code) + (when (id-token? code) + (set! code (id-token-header code))) + (jws-alg (the-id-token-header code))) + +(define-public (id-token-webid code) + (when (id-token? code) + (set! code (id-token-payload code))) + (string->uri + (assq-ref (the-id-token-payload code) 'webid))) + +(define-public (id-token-iss code) + (when (id-token? code) + (set! code (id-token-payload code))) + (string->uri + (assq-ref (the-id-token-payload code) 'iss))) + +(define-public (id-token-sub code) + (when (id-token? code) + (set! code (id-token-payload code))) + (assq-ref (the-id-token-payload code) 'sub)) + +(define-public (id-token-aud code) + (when (id-token? code) + (set! code (id-token-payload code))) + (string->uri + (assq-ref (the-id-token-payload code) 'aud))) + +(define-public (id-token-nonce code) + (when (id-token? code) + (set! code (id-token-payload code))) + (assq-ref (the-id-token-payload code) 'nonce)) + +(define-public (id-token-exp code) + (when (id-token? code) + (set! code (id-token-payload code))) + (time-utc->date + (make-time time-utc 0 (assq-ref + (the-id-token-payload code) + 'exp)))) + +(define-public (id-token-iat code) + (when (id-token? code) + (set! code (id-token-payload code))) + (time-utc->date + (make-time time-utc 0 (assq-ref + (the-id-token-payload code) + 'iat)))) + +(define*-public (id-token-decode str #:key (http-get http-get)) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-id-token str error)) + (lambda () + (jws-decode + str + (lambda (token) + (let ((iss (id-token-iss token))) + (let ((cfg + (with-exception-handler + (lambda (error) + (raise-cannot-fetch-issuer-configuration iss error)) + (lambda () + (get-oidc-configuration + (uri-host iss) + #:userinfo (uri-userinfo iss) + #:port (uri-port iss) + #:http-get http-get))))) + (with-exception-handler + (lambda (error) + (raise-cannot-fetch-jwks iss + (oidc-configuration-jwks-uri cfg) + error)) + (lambda () + (oidc-configuration-jwks cfg #:http-get http-get)))))))))) + +(define-public (id-token-encode id-token key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-id-token id-token key error)) + (lambda () + (jws-encode id-token key)))) + +(define*-public (issue-id-token + issuer-key + #:key + (alg #f) + (webid #f) + (iss #f) + (sub #f) + (aud #f) + (exp #f) + (iat #f)) + (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)) + issuer-key)) -- cgit v1.2.3