diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-09 18:46:48 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-13 01:06:38 +0200 |
commit | ded10e28782f289ad3db15320bcf619ab4336876 (patch) | |
tree | 32609fd9f1eb0d2f8a23105e09f193827d16a275 /src/scm/webid-oidc/jws.scm | |
parent | 7b62790238902e10edb83c07286cf0643b097997 (diff) |
Switch to a more sensible error reporting system
Diffstat (limited to 'src/scm/webid-oidc/jws.scm')
-rw-r--r-- | src/scm/webid-oidc/jws.scm | 316 |
1 files changed, 218 insertions, 98 deletions
diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index 43eb707..24a8bbc 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.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 @@ -17,91 +17,180 @@ (define-module (webid-oidc jws) #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (rnrs bytevectors) - #:use-module (ice-9 receive)) + #:use-module (ice-9 receive) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:declarative? #t + #:export + ( -(define-public (the-jws-header x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws-header x cause)) - (lambda () - (let ((alg (assq-ref x 'alg))) - (unless alg - (raise-missing-alist-key x 'alg)) - (unless (string? alg) - (raise-unsupported-alg alg)) - (case (string->symbol alg) - ((HS256 HS384 HS512 RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) - x) - (else - (raise-unsupported-alg (string->symbol alg)))))))) - -(define-public (the-jws-payload x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws-payload x cause)) - (lambda () - (unless (list? x) - (scm-error 'wrong-type-arg "the-jws-payload" "expected a list" '() (list x))) - x))) + &invalid-jws + make-invalid-jws + invalid-jws? -(define-public (the-jws x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws x cause)) - (lambda () - (unless (pair? x) - (scm-error 'wrong-type-arg "the-jws" "expected a pair" '() (list x))) - (cons (the-jws-header (car x)) - (the-jws-payload (cdr x)))))) + the-jws + jws? -(define-public (jws-header? x) - (false-if-exception - (and (the-jws-header x) #t))) + jws-alg -(define-public (jws-payload? x) - (false-if-exception - (and (the-jws-payload x) #t))) + &cannot-query-identity-provider + make-cannot-query-identity-provider + cannot-query-identity-provider? + cannot-query-identity-provider-value -(define-public (jws? x) - (false-if-exception - (and (the-jws x) #t))) + &signed-in-future + make-signed-in-future + signed-in-future? + error-signature-date + error-current-date -(define-public (make-jws header payload) - (the-jws (cons (the-jws-header header) - (the-jws-payload payload)))) + &expired + make-expired + expired? + error-expiration-date + ;; error-current-date works for that one too -(define-public (jws-header jws) - (car (the-jws jws))) + jws-decode + jws-encode -(define-public (jws-payload jws) - (cdr (the-jws jws))) + )) -(define-public (jws-alg jws) - (if (jws? jws) - (jws-alg (jws-header jws)) - (string->symbol (assq-ref (the-jws-header jws) 'alg)))) +(define-exception-type + &invalid-jws + &external-error + make-invalid-jws + invalid-jws?) + +(define (the-jws x) + (with-exception-handler + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the JWS is invalid: ~a") + (exception-message error)) + (format #f (G_ "the JWS is invalid"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) + (lambda () + (match x + ((header . payload) + (let examine-header ((header header) + (alg #f) + (other-header-fields '())) + (match header + (() + (let examine-payload ((payload payload) + (other-payload-fields '())) + (match payload + (() + (unless alg + (fail (format #f (G_ "the JWS header does not have an \"alg\" field")))) + `(((alg . ,(symbol->string alg)) + ,@(reverse other-header-fields)) + . ,(reverse other-payload-fields))) + ((((? symbol? key) . value) payload ...) + (examine-payload payload + `((,key . ,value) ,@other-payload-fields))) + (else + (fail (format #f (G_ "invalid JSON object as payload"))))))) + ((('alg . (? string? given-alg)) header ...) + (case (string->symbol given-alg) + ((HS256 HS384 HS512 + RS256 RS384 RS512 + ES256 ES384 ES512 + PS256 PS384 PS512) + #t) + (else + (fail (format #f (G_ "invalid signature algorithm: ~s") given-alg)))) + (examine-header header (or alg (string->symbol given-alg)) + other-header-fields)) + ((('alg . invalid) header ...) + (fail (format #f (G_ "invalid \"alg\" value: ~s") invalid))) + ((((? symbol? key) . value) header ...) + (examine-header header alg + `((,key . ,value) ,@other-header-fields))) + (else + (fail (format #f (G_ "invalid JSON object as header"))))))) + (else + (fail (format #f (G_ "this is not a pair")))))))) + +(define (jws? x) + (false-if-exception + (the-jws x))) + +(define (jws-alg jws) + (match (the-jws jws) + ((header . _) + (string->symbol (assq-ref header 'alg))))) (define (split-in-3-parts string separator) - (let ((parts (list->vector (string-split string separator)))) - (unless (eqv? (vector-length parts) 3) - (raise-not-in-3-parts string separator)) - (values (vector-ref parts 0) (vector-ref parts 1) (vector-ref parts 2)))) + (match (string-split string separator) + ((header payload signature) + (values header payload signature)) + (else + (let ((final-message + (format #f (G_ "the encoded JWS is not in 3 parts")))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message))))))) (define (base64-decode-json str) (with-exception-handler (lambda (error) - (cond - (((record-predicate ¬-base64) error) - (raise-exception error)) - (((record-predicate ¬-json) error) - (raise-exception error)) - (else - ;; From utf8->string - (raise-not-base64 str error)))) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64: ~a") + (exception-message error)) + (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () - (stubs:json-string->scm (utf8->string (stubs:base64-decode str)))))) + (stubs:json-string->scm + (utf8->string (stubs:base64-decode str)))))) + +(define-exception-type + &cannot-query-identity-provider + &external-error + make-cannot-query-identity-provider + cannot-query-identity-provider? + (identity-provider cannot-query-identity-provider-value)) + +(define-exception-type + &signed-in-future + &external-error + make-signed-in-future + signed-in-future? + (signature-date error-signature-date) + (current-date error-current-date*)) + +(define-exception-type + &expired + &external-error + make-expired + expired? + (expiration-date error-expiration-date) + (current-date error-current-date**)) + +(define error-current-date + (match-lambda + ((or ($ &signed-in-future _ date) + ($ &expired _ date) + ($ &compound-exception (($ &signed-in-future _ date) _ ...)) + ($ &compound-exception (($ &expired _ date) _ ...))) + date) + (($ &compound-exception (_ sub-exceptions ...)) + (error-current-date (apply make-exception sub-exceptions))) + (else #f))) (define (parse str verify) (receive (header payload signature) @@ -109,31 +198,53 @@ (let ((base (string-append header "." payload)) (header (base64-decode-json header)) (payload (base64-decode-json payload))) - (let ((ret (make-jws header payload))) + (let ((ret `(,header . ,payload))) (verify ret base signature) ret)))) (define (verify-any alg keys payload signature) - (define (aux candidates) - (if (null? keys) - (raise-no-matching-key keys alg payload signature) - (let ((next-ok - (with-exception-handler - (lambda (error) - #f) - (lambda () - (stubs:verify alg (car candidates) payload signature) - #t) - #:unwind? #t - #:unwind-for-type &invalid-signature))) - (or next-ok - (aux (cdr candidates)))))) - (aux keys)) - -(define-public (jws-decode str lookup-keys) + (let try-with-key ((keys keys)) + (match keys + (() + (let ((final-message + (format #f (G_ "the JWS is not signed by any of the expected set of public keys")))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message))))) + ((next-key keys ...) + (with-exception-handler + (lambda (error) + (unless (stubs:invalid-signature? error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "while verifying the JWS signature: ~a") + (exception-message error)) + (format #f (G_ "an unexpected error happened while verifying a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) + (try-with-key keys)) + (lambda () + (stubs:verify alg next-key payload signature)) + #:unwind? #t + #:unwind-for-type stubs:&invalid-signature))))) + +(define (jws-decode str lookup-keys) (with-exception-handler (lambda (error) - (raise-cannot-decode-jws str error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot decode a JWS: ~a") + (exception-message error)) + (format #f (G_ "cannot decode a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () (parse str (lambda (jws payload signature) @@ -143,17 +254,26 @@ (else keys)))) (verify-any (jws-alg jws) keys payload signature)))))))) -(define-public (jws-encode jws key) +(define (jws-encode jws key) (with-exception-handler (lambda (error) - (raise-cannot-encode-jws jws key error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot encode a JWS: ~a") + (exception-message error)) + (format #f (G_ "cannot encode a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () - (let ((header (jws-header jws)) - (payload (jws-payload jws))) - (let ((header (stubs:scm->json-string header)) - (payload (stubs:scm->json-string payload))) - (let ((header (stubs:base64-encode header)) - (payload (stubs:base64-encode payload))) - (let ((payload (string-append header "." payload))) - (let ((signature (stubs:sign (jws-alg jws) key payload))) - (string-append payload "." signature))))))))) + (match jws + ((header . payload) + (let ((header (stubs:scm->json-string header)) + (payload (stubs:scm->json-string payload))) + (let ((header (stubs:base64-encode header)) + (payload (stubs:base64-encode payload))) + (let ((payload (string-append header "." payload))) + (let ((signature (stubs:sign (jws-alg jws) key payload))) + (string-append payload "." signature)))))))))) |