From 814ab9feab59c499d3221971b0524972b0d161a4 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Fri, 27 Nov 2020 19:42:01 +0100 Subject: Implement JWS encoding and decoding --- src/scm/webid-oidc.scm | 3 +- src/scm/webid-oidc/Makefile.am | 7 +- src/scm/webid-oidc/errors.scm | 104 ++++++++++++++++++++++++++++++ src/scm/webid-oidc/jws.scm | 143 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 253 insertions(+), 4 deletions(-) create mode 100644 src/scm/webid-oidc/jws.scm (limited to 'src/scm') diff --git a/src/scm/webid-oidc.scm b/src/scm/webid-oidc.scm index a9a4699..38c563d 100644 --- a/src/scm/webid-oidc.scm +++ b/src/scm/webid-oidc.scm @@ -1,2 +1,3 @@ (define-module (webid-oidc) - #:use-module (webid-oidc config)) + #:use-module (webid-oidc config) + #:use-module (webid-oidc jws)) diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 8c504d2..aca5f0c 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -2,10 +2,11 @@ dist_webidoidcmod_DATA += \ %reldir%/errors.scm \ %reldir%/stubs.scm \ %reldir%/testing.scm \ - %reldir%/jwk.scm - + %reldir%/jwk.scm \ + %reldir%/jws.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ %reldir%/testing.go \ - %reldir%/jwk.go + %reldir%/jwk.go \ + %reldir%/jws.go diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index ad8fef3..e6c7a3e 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -104,6 +104,86 @@ (raise-exception ((record-constructor &invalid-signature) key payload signature))) +(define-public ¬-a-jws-header + (make-exception-type + '¬-a-jws-header + &external-error + '(value cause))) + +(define-public (raise-not-a-jws-header value cause) + (raise-exception + ((record-constructor ¬-a-jws-header) value cause))) + +(define-public ¬-a-jws-payload + (make-exception-type + '¬-a-jws-payload + &external-error + '(value cause))) + +(define-public (raise-not-a-jws-payload value cause) + (raise-exception + ((record-constructor ¬-a-jws-payload) value cause))) + +(define-public ¬-a-jws + (make-exception-type + '¬-a-jws + &external-error + '(value cause))) + +(define-public (raise-not-a-jws value cause) + (raise-exception + ((record-constructor ¬-a-jws-payload) value cause))) + +(define-public ¬-in-3-parts + (make-exception-type + '¬-in-3-parts + &external-error + '(string separator))) + +(define-public (raise-not-in-3-parts string separator) + (raise-exception + ((record-constructor ¬-in-3-parts) string separator))) + +(define-public &missing-alist-key + (make-exception-type + '&missing-alist-key + &external-error + '(value key))) + +(define-public (raise-missing-alist-key value key) + (raise-exception + ((record-constructor &missing-alist-key) value key))) + +(define-public &no-matching-key + (make-exception-type + '&no-matching-key + &external-error + '(candidates alg payload signature other-problems))) + +(define-public (raise-no-matching-key candidates alg payload signature) + (raise-exception + ((record-constructor &no-matching-key) candidates alg payload signature))) + +(define-public &cannot-decode-jws + (make-exception-type + '&cannot-decode-jws + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-jws value cause) + (raise-exception + ((record-constructor &cannot-decode-jws) value cause))) + +(define-public &cannot-encode-jws + (make-exception-type + '&cannot-encode-jws + &external-error + '(jws key cause))) + +(define-public (raise-cannot-encode-jws jws key cause) + (raise-exception + ((record-constructor &cannot-encode-jws) jws key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -156,6 +236,30 @@ ((&unsupported-alg) (format #f (G_ "the value ~s does not identify a hash algorithm") (get 'value))) + ((&missing-alist-key) + (format #f (G_ "the value ~s is not an alist or misses key ~s") + (get 'value) (get 'key))) + ((¬-a-jws-header) + (format #f (G_ "the value ~s is not a JWS header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-jws-payload) + (format #f (G_ "the value ~s is not a JWS payload (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-jws) + (format #f (G_ "the value ~s is not a JWS (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-in-3-parts) + (format #f (G_ "the string ~s cannot be split in 3 parts with ~s") + (get 'string) (get 'separator))) + ((&no-matching-key) + (format #f (G_ "all key candidates failed to verify signature ~s with algorithm ~s and payload ~a (there were ~a: ~s)") + (get 'signature) (get 'alg) (get 'payload) (length (get 'candidates)) (get 'candidates))) + ((&cannot-decode-jws) + (format #f (G_ "I cannot decode JWS ~a (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-jws) + (format #f (G_ "I cannot encode JWS ~a (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm new file mode 100644 index 0000000..fb3edd1 --- /dev/null +++ b/src/scm/webid-oidc/jws.scm @@ -0,0 +1,143 @@ +(define-module (webid-oidc jws) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 receive)) + +(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))) + +(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)))))) + +(define-public (jws-header? x) + (false-if-exception + (and (the-jws-header x) #t))) + +(define-public (jws-payload? x) + (false-if-exception + (and (the-jws-payload x) #t))) + +(define-public (jws? x) + (false-if-exception + (and (the-jws x) #t))) + +(define-public (make-jws header payload) + (the-jws (cons (the-jws-header header) + (the-jws-payload payload)))) + +(define-public (jws-header jws) + (car (the-jws jws))) + +(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 (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)))) + +(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)))) + (lambda () + (stubs:json-string->scm (utf8->string (stubs:base64-decode str)))))) + +(define (parse str verify) + (receive (header payload signature) + (split-in-3-parts str #\.) + (let ((base (string-append header "." payload)) + (header (base64-decode-json header)) + (payload (base64-decode-json payload))) + (let ((ret (make-jws 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) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-jws str error)) + (lambda () + (parse str + (lambda (jws payload signature) + (let ((keys (lookup-keys jws))) + (let ((keys (cond ((jwk? keys) (list keys)) + ((jwks? keys) (jwks-keys keys)) + (else keys)))) + (verify-any (jws-alg jws) keys payload signature)))))))) + +(define-public (jws-encode jws key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-jws jws key 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))))))))) -- cgit v1.2.3