JWS: use GOOPS

1 files changed, 397 insertions, 84 deletions

diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm
index 3e5e50b..af83c90 100644
--- a/src/scm/webid-oidc/jws.scm
+++ b/src/scm/webid-oidc/jws.scm
@@ -18,13 +18,30 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc oidc-configuration)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs)
+  #:use-module (web uri)
   #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   (&jti-found . &nonce-found)
+   (make-jti-found . make-nonce-found)
+   (jti-found? . nonce-found?)
+   (jti-found-jti . nonce-found-nonce)
+   )
+  #:replace
+  (
+   exp ;; This is a function in guile
+   )
   #:export
   (
 
@@ -32,10 +49,16 @@
    make-invalid-jws
    invalid-jws?
 
-   the-jws
-   jws?
+   <token>
+
+   <time-bound-token> iat default-validity has-explicit-exp?
+   nonce-field-name ;; DPoP proofs use 'jti instead of 'nonce
+
+   <oidc-token> iss
 
-   jws-alg
+   <single-use-token> nonce
+   
+   token->jwt
 
    &cannot-query-identity-provider
    make-cannot-query-identity-provider
@@ -54,8 +77,11 @@
    error-expiration-date
    ;; error-current-date works for that one too
 
-   jws-decode
-   jws-encode
+   lookup-keys
+   verify
+   decode
+   encode
+   issue
 
    ))
 
@@ -65,70 +91,259 @@
   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")))))
+(define-class <token> ()
+  (alg #:init-keyword #:alg #:accessor alg))
+
+(define (key-alg key)
+  (alg key))
+
+(define-method (initialize (token <token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((alg #f)
+    (signing-key #f)
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((alg alg)
+                       (signing-key signing-key)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((string? alg)
+       (do-initialize (string->symbol alg) signing-key jwt-header jwt-payload))
+      (alg
+       (case alg
+         ((HS256 HS384 HS512
+                 RS256 RS384 RS512
+                 ES256 ES384 ES512
+                 PS256 PS384 PS512)
+          (slot-set! token 'alg alg))
+         (else
           (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)))))
+            (make-exception-with-message
+             (format #f (G_ "unsupported JWS algorithm: ~s") alg)))))))
+      (signing-key
+       (do-initialize (key-alg signing-key) #f jwt-payload jwt-header))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-header 'alg) #f #f #f))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a token either #:alg or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <generic-with-default> (<generic>)
+  ;; neutral is the list of values that are returned when there are no
+  ;; next methods.
+  (neutral #:init-keyword #:neutral))
+
+(define-method (no-next-method (generic <generic-with-default>) args)
+  (apply values (slot-ref generic 'neutral)))
+
+(define-method (no-applicable-method (generic <generic-with-default>) args)
+  (apply values (slot-ref generic 'neutral)))
+
+(define-class <time-bound-token> (<token>)
+  (iat #:init-keyword #:iat #:accessor iat)
+  (exp #:init-keyword #:exp #:accessor exp))
+
+(define default-validity
+  (make <generic-with-default>
+    #:name 'default-validity
+    #:neutral (list #f)))
+
+(define-method (has-explicit-exp? (token <time-bound-token>))
+  ;; Change it to #f when the token should not have an explicit
+  ;; expiration date, such as DPoP proofs
+  #t)
+
+(define-method (initialize (token <time-bound-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((iat ((p:current-date)))
+    (exp #f)
+    (validity (default-validity token))
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((iat iat)
+                       (exp exp)
+                       (validity validity)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((integer? iat)
+       (do-initialize (make-time time-utc 0 iat) exp validity jwt-header jwt-payload))
+      ((time? iat)
+       (do-initialize (time-utc->date iat) exp validity jwt-header jwt-payload))
+      ((and (not exp) (date? iat) (integer? validity))
+       (do-initialize iat
+                      (+ (time-second (date->time-utc iat))
+                         validity)
+                      validity
+                      jwt-header
+                      jwt-payload))
+      ((integer? exp)
+       (do-initialize iat (make-time time-utc 0 exp) validity jwt-header jwt-payload))
+      ((time? exp)
+       (do-initialize iat (time-utc->date exp) validity jwt-header jwt-payload))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload 'iat)
+                      (and (has-explicit-exp? token)
+                           (assq-ref jwt-payload 'exp))
+                      validity #f #f))
+      ((and iat exp)
+       (unless (date? iat)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:iat should be a date")
+                    '()
+                    (list iat)))
+       (unless (date? exp)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:exp should be a date")
+                    '()
+                    (list exp)))
+       (slot-set! token 'iat iat)
+       (slot-set! token 'exp exp))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a time-bound token, either its required fields (#:iat, and either #:exp or #:validity) or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <oidc-token> (<token>)
+  (iss #:init-keyword #:iss #:accessor iss))
+
+(define-method (default-validity (token <oidc-token>))
+  (let ((next (next-method))
+        (mine 3600))
+    (if (and next (< next mine))
+        next
+        mine)))
+
+(define-method (initialize (token <oidc-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((iss #f)
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((iss iss)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((string? iss)
+       (do-initialize (string->uri iss) jwt-header jwt-payload))
+      (iss
+       (unless (uri? iss)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:iss should be an URI")
+                    '()
+                    (list iss)))
+       (slot-set! token 'iss iss))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload 'iss) #f #f))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making an OIDC token, either its required #:iss field or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <single-use-token> (<time-bound-token>)
+  (nonce #:init-keyword #:nonce #:accessor nonce))
+
+(define-method (default-validity (token <single-use-token>))
+  (let ((next (next-method))
+        (mine 120))
+    (if (and next (< next mine))
+        next
+        mine)))
+
+(define nonce-field-name
+  (make <generic-with-default>
+    #:name 'nonce-field-name
+    #:neutral (list 'nonce)))
+
+(define-method (nonce-field-name (token <top>))
+  ;; Without this method, this is an infinite loop.
+  (next-method))
+
+(define-method (initialize (token <single-use-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((nonce (stubs:random 12))
+    (jwt-header #f)
+    (jwt-payload #f))
+   ;; The maximum validity is 2 minutes
+   (let ((iat (time-second (date->time-utc (iat token))))
+         (exp (time-second (date->time-utc (exp token)))))
+     (let ((validity (- exp iat)))
+       (when (> validity 120)
+         (let ((true-exp (+ iat 120)))
+           (slot-set! token 'exp (time-utc->date (make-time time-utc 0 true-exp)))))))
+   (let do-initialize ((nonce nonce)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload (nonce-field-name token)) #f #f))
+      (nonce
+       (unless (string? nonce)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:nonce should be a string")
+                    '()
+                    (list nonce)))
+       (slot-set! token 'nonce nonce))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a single-use token, either its required #:nonce field or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define token->jwt
+  (make <generic-with-default>
+    #:name 'token->jwt
+    #:neutral (list '() '())))
+
+(define-method (token->jwt (token <token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     `((alg . ,(symbol->string (alg token)))
+       ,@base-header)
+     base-payload)))
+
+(define-method (token->jwt (token <time-bound-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((iat . ,(time-second (date->time-utc (iat token))))
+              ,@(if (has-explicit-exp? token)
+                    `((exp . ,(time-second (date->time-utc (exp token)))))
+                    '())
+              ,@base-payload))))
+
+(define-method (token->jwt (token <single-use-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((,(nonce-field-name token) . ,(nonce token))
+              ,@base-payload))))
+
+(define-method (token->jwt (token <oidc-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((iss . ,(uri->string (iss token)))
+              ,@base-payload))))
 
 (define (split-in-3-parts string separator)
   (match (string-split string separator)
@@ -193,14 +408,14 @@
      (error-current-date (apply make-exception sub-exceptions)))
     (else #f)))
 
-(define (parse str verify)
+(define (parse token-class str verify-signature)
   (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 `(,header . ,payload)))
-        (verify ret base signature)
+      (let ((ret (make token-class #:jwt-header header #:jwt-payload payload)))
+        (verify-signature ret base signature)
         ret))))
 
 (define (verify-any alg keys payload signature)
@@ -245,7 +460,102 @@
 (define-method (keys (keys <list>))
   (map public-key keys))
 
-(define (jws-decode str lookup-keys)
+(define lookup-keys
+  (make <generic-with-default>
+    #:name 'lookup-keys
+    #:neutral (list '())))
+
+(define-method (lookup-keys (token <oidc-token>) args)
+  (let-keywords
+   args #f
+   ((http-request http-request))
+   (let ((iss (iss token)))
+     (let ((cfg
+            (with-exception-handler
+                (lambda (error)
+                  (let ((final-message
+                         (if (exception-with-message? error)
+                             (format #f (G_ "I cannot query the identity provider configuration: ~a")
+                                     (exception-message error))
+                             (format #f (G_ "I cannot query the identity provider configuration")))))
+                    (raise-exception
+                     (make-exception
+                      (make-cannot-query-identity-provider iss)
+                      (make-exception-with-message final-message)
+                      error))))
+              (lambda ()
+                (get-oidc-configuration
+                 (uri-host iss)
+                 #:userinfo (uri-userinfo iss)
+                 #:port (uri-port iss)
+                 #:http-get
+                 (lambda* (uri . args)
+                   (apply http-request uri #:method 'GET args)))))))
+       (with-exception-handler
+           (lambda (error)
+             (raise-exception
+              (make-exception
+               (make-cannot-query-identity-provider iss)
+               (make-exception-with-message
+                (if (exception-with-message? error)
+                    (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a")
+                            (exception-message error))
+                    (format #f (G_ "I cannot query the JWKS URI of the identity provider")))))))
+         (lambda ()
+           (append
+               (keys (next-method))
+               (keys
+                (oidc-configuration-jwks
+                 cfg
+                 #:http-get 
+                 (lambda* (uri . args)
+                   (apply http-request uri #:method 'GET args)))))))))))
+
+(define verify
+  (make <generic-with-default>
+    #:name 'verify
+    #:neutral (list #t)))
+
+(define-method (verify (token <time-bound-token>) args)
+  (next-method)
+  (let-keywords
+   args #t
+   ((current-date ((p:current-date))))
+   (let ((iat (iat token))
+         (exp (exp token)))
+     (let ((iat-s (time-second (date->time-utc iat)))
+           (exp-s (time-second (date->time-utc exp)))
+           (current-s (time-second (date->time-utc current-date))))
+       (when (>= iat-s (+ current-s 5))
+         (let ((final-message
+                (format #f (G_ "the token is signed in the future, ~a, relative to current ~a")
+                        (date->string iat)
+                        (date->string current-date))))
+           (raise-exception
+            (make-exception
+             (make-signed-in-future iat current-date)
+             (make-exception-with-message final-message)))))
+       (when (>= current-s exp-s)
+         (let ((final-message
+                (format #f (G_ "the token 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)))))))))
+
+(define-method (verify (token <single-use-token>) args)
+  (next-method)
+  (let-keywords
+   args #t
+   ((current-date ((p:current-date))))
+   (let ((exp (exp token)))
+     (let ((exp-s (time-second (date->time-utc exp)))
+           (current-s (time-second (date->time-utc current-date))))
+       (jti-check (nonce token) (- exp-s current-s))))))
+
+(define* (decode token-class str . args)
   (with-exception-handler
       (lambda (error)
         (let ((final-message
@@ -259,12 +569,13 @@
             (make-exception-with-message final-message)
             error))))
     (lambda ()
-      (parse str
-             (lambda (jws payload signature)
-               (let ((k (keys (lookup-keys jws))))
-                 (verify-any (jws-alg jws) k payload signature)))))))
+      (parse token-class str
+             (lambda (token payload signature)
+               (let ((k (keys (lookup-keys token args))))
+                 (verify-any (alg token) k payload signature))
+               (verify token args))))))
 
-(define (jws-encode jws key)
+(define (encode token key)
   (with-exception-handler
       (lambda (error)
         (let ((final-message
@@ -278,12 +589,14 @@
             (make-exception-with-message final-message)
             error))))
     (lambda ()
-      (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->jwk key) payload)))
-                 (string-append payload "." signature))))))))))
+      (receive (header payload) (token->jwt token)
+        (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 (alg token) (key->jwk key) payload)))
+                (string-append payload "." signature)))))))))
+
+(define* (issue token-class issuer-key . args)
+  (encode (apply make token-class #:signing-key issuer-key args) issuer-key))