diff options
Diffstat (limited to 'src/scm/webid-oidc/authorization-code.scm')
-rw-r--r-- | src/scm/webid-oidc/authorization-code.scm | 317 |
1 files changed, 187 insertions, 130 deletions
diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 267d67a..95dcc4a 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -21,146 +21,203 @@ #:use-module (webid-oidc jti) #:use-module ((webid-oidc parameters) #:prefix p:) #: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-payload x) #t))) - -(define-public (the-authorization-code x) + #:use-module (srfi srfi-19) + #:use-module (webid-oidc web-i18n) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:declarative? #t + #:export + ( + + &invalid-authorization-code + 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 + )) + +(define-exception-type + &invalid-authorization-code + &external-error + make-invalid-authorization-code + invalid-authorization-code?) + +(define (the-authorization-code x) (with-exception-handler (lambda (error) - (raise-not-an-authorization-code x 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 () - (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 str jwk) + (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 (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) - (raise-cannot-decode-authorization-code str 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 (time-second (date->time-utc (authorization-code-exp code)))) - (current-time (time-second (date->time-utc ((p:current-date)))))) - (unless (<= current-time exp) - (raise-authorization-code-expired exp current-time)) - (unless (jti-check (authorization-code-jti code) - (- exp current-time)) - (with-exception-handler - (lambda (error) - (raise-jti-found (authorization-code-jti code) error)) - (lambda () - (error "the jti-check function returned #f")))) - code)))))) - -(define-public (authorization-code-encode authorization-code key) + (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) (with-exception-handler (lambda (error) - (raise-cannot-encode-authorization-code authorization-code key 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)))) (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)) +(define* (issue-authorization-code issuer-key + #:key + alg + (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))) + . ((webid . ,(uri->string webid)) + (client_id . ,(uri->string client-id)) + (exp . ,exp) + (jti . ,(stubs:random 12)))) + issuer-key))) |