diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-04-27 14:07:10 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-06-05 16:13:45 +0200 |
commit | 305d9fb0d15bf90430cc44772a016d60139cab45 (patch) | |
tree | afb96f316bc18d26d87bf3ea878336d40391a194 /src | |
parent | 8411f72f54a2ec02fa8c572d9c368a1be5b7d9d6 (diff) |
Define the access token API
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/access-token.scm | 205 | ||||
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 208 |
3 files changed, 417 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index ebf6811..a63fa89 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -5,7 +5,8 @@ dist_webidoidcmod_DATA += \ %reldir%/jwk.scm \ %reldir%/jws.scm \ %reldir%/cache.scm \ - %reldir%/oidc-configuration.scm + %reldir%/oidc-configuration.scm \ + %reldir%/access-token.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -13,4 +14,5 @@ webidoidcgo_DATA += \ %reldir%/jwk.go \ %reldir%/jws.go \ %reldir%/cache.go \ - %reldir%/oidc-configuration.go + %reldir%/oidc-configuration.go \ + %reldir%/access-token.go diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm new file mode 100644 index 0000000..34afcdc --- /dev/null +++ b/src/scm/webid-oidc/access-token.scm @@ -0,0 +1,205 @@ +(define-module (webid-oidc access-token) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc oidc-configuration) + #: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-access-token-header x) + (with-exception-handler + (lambda (error) + (raise-not-an-access-token-header x error)) + (lambda () + (the-jws-header x)))) + +(define-public (access-token-header? x) + (false-if-exception + (and (the-access-token-header x) #t))) + +(define-public (the-access-token-payload x) + (with-exception-handler + (lambda (error) + (raise-not-an-access-token-payload x error)) + (lambda () + (let ((x (the-jws-payload x))) + (let ((webid (assq-ref x 'webid)) + (iss (assq-ref x 'iss)) + (aud (assq-ref x 'aud)) + (iat (assq-ref x 'iat)) + (exp (assq-ref x 'exp)) + (cnf (assq-ref x 'cnf)) + (client-id (assq-ref x 'client_id))) + (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 (equal? aud "solid") + (raise-incorrect-aud-field aud)) + (unless (integer? iat) + (raise-incorrect-iat-field iat)) + (unless (and (integer? exp) (>= exp iat)) + (raise-incorrect-exp-field exp)) + (unless (and client-id (string? client-id) (string->uri client-id)) + (raise-incorrect-client-id-field client-id)) + (unless (and cnf (assq-ref cnf 'jkt) (string? (assq-ref cnf 'jkt))) + (raise-incorrect-cnf/jkt-field (and cnf (assq-ref cnf 'jkt)))) + x))))) + +(define-public (access-token-payload? x) + (false-if-exception + (and (the-access-token-header x) #t))) + +(define-public (the-access-token x) + (with-exception-handler + (lambda (cause) + (raise-not-an-access-token x cause)) + (lambda () + (cons (the-access-token-header (car x)) + (the-access-token-payload (cdr x)))))) + +(define-public (access-token? x) + (false-if-exception + (and (the-access-token x) #t))) + +(define-public (make-access-token header payload) + (the-access-token + (cons header payload))) + +(define-public (make-access-token-payload webid iss iat exp cnf/jkt client-id) + (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? client-id) + (set! client-id (uri->string client-id))) + (the-access-token-payload + `((webid . ,webid) + (iss . ,iss) + (aud . "solid") + (iat . ,iat) + (exp . ,exp) + (cnf . ((jkt . ,cnf/jkt))) + (client_id . ,client-id)))) + +(define-public (access-token-header code) + (car (the-access-token code))) + +(define-public (access-token-payload code) + (cdr (the-access-token code))) + +(define-public (access-token-alg code) + (when (access-token? code) + (set! code (access-token-header code))) + (jws-alg (the-access-token-header code))) + +(define-public (access-token-webid code) + (when (access-token? code) + (set! code (access-token-payload code))) + (string->uri + (assq-ref (the-access-token-payload code) 'webid))) + +(define-public (access-token-iss code) + (when (access-token? code) + (set! code (access-token-payload code))) + (string->uri + (assq-ref (the-access-token-payload code) 'iss))) + +(define-public (access-token-aud code) + (when (access-token? code) + (set! code (access-token-payload code))) + (assq-ref (the-access-token-payload code) 'aud)) + +(define-public (access-token-exp code) + (when (access-token? code) + (set! code (access-token-payload code))) + (time-utc->date + (make-time time-utc 0 (assq-ref + (the-access-token-payload code) + 'exp)))) + +(define-public (access-token-iat code) + (when (access-token? code) + (set! code (access-token-payload code))) + (time-utc->date + (make-time time-utc 0 (assq-ref + (the-access-token-payload code) + 'iat)))) + +(define-public (access-token-cnf/jkt code) + (when (access-token? code) + (set! code (access-token-payload code))) + (assq-ref + (assq-ref (the-access-token-payload code) 'cnf) + 'jkt)) + +(define-public (access-token-client-id code) + (when (access-token? code) + (set! code (access-token-payload code))) + (string->uri + (assq-ref (the-access-token-payload code) 'client_id))) + +(define*-public (access-token-decode str #:key (http-get http-get)) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-access-token str error)) + (lambda () + (jws-decode + str + (lambda (token) + (let ((iss (access-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 (access-token-encode access-token key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-access-token access-token key error)) + (lambda () + (jws-encode access-token key)))) + +(define*-public (issue-access-token + issuer-key + #:key + (alg #f) + (webid #f) + (iss #f) + (iat #f) + (exp #f) + (client-key #f) + (cnf/jkt #f) + (client-id #f)) + (when client-key + (set! cnf/jkt (jkt client-key))) + (access-token-encode + (make-access-token + `((alg . ,(if (symbol? alg) (symbol->string alg) alg))) + (make-access-token-payload + webid iss iat exp cnf/jkt client-id)) + issuer-key)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index beeaaea..50d526c 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -227,6 +227,146 @@ (raise-exception ((record-constructor ¬-an-oidc-configuration) value cause))) +(define-public &incorrect-webid-field + (make-exception-type + '&incorrect-webid-field + &external-error + '(value))) + +(define-public (raise-incorrect-webid-field value) + (raise-exception + ((record-constructor &incorrect-webid-field) value))) + +(define-public &incorrect-iss-field + (make-exception-type + '&incorrect-iss-field + &external-error + '(value))) + +(define-public (raise-incorrect-iss-field value) + (raise-exception + ((record-constructor &incorrect-iss-field) value))) + +(define-public &incorrect-aud-field + (make-exception-type + '&incorrect-aud-field + &external-error + '(value))) + +(define-public (raise-incorrect-aud-field value) + (raise-exception + ((record-constructor &incorrect-aud-field) value))) + +(define-public &incorrect-iat-field + (make-exception-type + '&incorrect-iat-field + &external-error + '(value))) + +(define-public (raise-incorrect-iat-field value) + (raise-exception + ((record-constructor &incorrect-iat-field) value))) + +(define-public &incorrect-exp-field + (make-exception-type + '&incorrect-exp-field + &external-error + '(value))) + +(define-public (raise-incorrect-exp-field value) + (raise-exception + ((record-constructor &incorrect-exp-field) value))) + +(define-public &incorrect-cnf/jkt-field + (make-exception-type + '&incorrect-cnf/jkt-field + &external-error + '(value))) + +(define-public (raise-incorrect-cnf/jkt-field value) + (raise-exception + ((record-constructor &incorrect-cnf/jkt-field) value))) + +(define-public &incorrect-client-id-field + (make-exception-type + '&incorrect-client-id-field + &external-error + '(value))) + +(define-public (raise-incorrect-client-id-field value) + (raise-exception + ((record-constructor &incorrect-client-id-field) value))) + +(define-public ¬-an-access-token + (make-exception-type + '¬-an-access-token + &external-error + '(value cause))) + +(define-public (raise-not-an-access-token value cause) + (raise-exception + ((record-constructor ¬-an-access-token) value cause))) + +(define-public ¬-an-access-token-header + (make-exception-type + '¬-an-access-token-header + &external-error + '(value cause))) + +(define-public (raise-not-an-access-token-header value cause) + (raise-exception + ((record-constructor ¬-an-access-token-header) value cause))) + +(define-public ¬-an-access-token-payload + (make-exception-type + '¬-an-access-token-payload + &external-error + '(value cause))) + +(define-public (raise-not-an-access-token-payload value cause) + (raise-exception + ((record-constructor ¬-an-access-token-payload) value cause))) + +(define-public &cannot-fetch-issuer-configuration + (make-exception-type + '&cannot-fetch-issuer-configuration + &external-error + '(issuer cause))) + +(define-public (raise-cannot-fetch-issuer-configuration issuer cause) + (raise-exception + ((record-constructor &cannot-fetch-issuer-configuration) issuer cause))) + +(define-public &cannot-fetch-jwks + (make-exception-type + '&cannot-fetch-jwks + &external-error + '(issuer uri cause))) + +(define-public (raise-cannot-fetch-jwks issuer uri cause) + (raise-exception + ((record-constructor &cannot-fetch-jwks) issuer uri cause))) + +(define-public &cannot-decode-access-token + (make-exception-type + '&cannot-decode-access-token + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-access-token value cause) + (raise-exception + ((record-constructor &cannot-decode-access-token) value cause))) + +(define-public &cannot-encode-access-token + (make-exception-type + '&cannot-encode-access-token + &external-error + '(access-token key cause))) + +(define-public (raise-cannot-encode-access-token access-token key cause) + (raise-exception + ((record-constructor &cannot-encode-access-token) access-token key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -322,6 +462,74 @@ ((¬-an-oidc-configuration) (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)") (get 'value) (recurse (get 'cause)))) + ((&incorrect-webid-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the webid field is incorrect: ~s") value) + (format #f (G_ "the webid field is missing"))))) + ((&incorrect-iss-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the iss field is incorrect: ~s") value) + (format #f (G_ "the iss field is missing"))))) + ((&incorrect-aud-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the aud field is incorrect: ~s") value) + (format #f (G_ "the aud field is missing"))))) + ((&incorrect-iat-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the iat field is incorrect: ~s") value) + (format #f (G_ "the iat field is missing"))))) + ((&incorrect-exp-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the exp field is incorrect: ~s") value) + (format #f (G_ "the exp field is missing"))))) + ((&incorrect-cnf/jkt-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the cnf/jkt field is incorrect: ~s") value) + (format #f (G_ "the cnf/jkt field is missing"))))) + ((&incorrect-client-id-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the client-id field is incorrect: ~s") value) + (format #f (G_ "the client-id field is missing"))))) + ((¬-an-access-token) + (format #f (G_ "~s is not an access token (because ~a)" + (get 'value) (recurse (get 'cause))))) + ((¬-an-access-token-header) + (format #f (G_ "~s is not an access token header (because ~a)" + (get 'value) (recurse (get 'cause))))) + ((¬-an-access-token-payload) + (format #f (G_ "~s is not an access token payload (because ~a)" + (get 'value) (recurse (get 'cause))))) + ((&cannot-fetch-issuer-configuration) + (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)" + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (recurse (get 'cause))))) + ((&cannot-fetch-jwks) + (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)" + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (let ((uri (get 'uri))) + (when (uri? uri) + (set! uri (uri->string uri))) + uri) + (recurse (get 'cause))))) + ((&cannot-decode-access-token) + (format #f (G_ "I cannot decode ~s as an access token (because ~a)" + (get 'value) (recurse (get 'cause))))) + ((&cannot-encode-access-token) + (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)") + (get 'access-token) (get 'key) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) |