JWS: use GOOPS

1 files changed, 113 insertions, 297 deletions

diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm
index 7e67270..7c23126 100644
--- a/src/scm/webid-oidc/access-token.scm
+++ b/src/scm/webid-oidc/access-token.scm
@@ -29,7 +29,17 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 receive)
+  #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat exp iss
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
 
@@ -37,21 +47,7 @@
    make-invalid-access-token
    invalid-access-token?
 
-   the-access-token
-   access-token?
-
-   access-token-alg
-
-   access-token-webid
-   access-token-iss
-   access-token-aud
-   access-token-iat
-   access-token-exp
-   access-token-client-id
-   access-token-cnf/jkt
-
-   access-token-decode
-   issue-access-token
+   <access-token> webid aud client-id cnf/jkt
    ))
 
 (define-exception-type
@@ -60,289 +56,109 @@
   make-invalid-access-token
   invalid-access-token?)
 
-;; The order is meaningful in this module, the-access-token reorders
-;; them.
-(define (the-access-token x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (cond
-                ((invalid-jws? error)
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an access token, because it is not even a JWS: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an access token, because it is not even a JWS"))))
-                (else
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an access token: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an access token")))))))
-          (raise-exception
-           (make-exception
-            (make-invalid-access-token)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match (the-jws x)
-        ((header . payload)
-         (let examine-payload ((payload payload)
-                               (webid #f)
-                               (iss #f)
-                               (aud #f)
-                               (iat #f)
-                               (exp #f)
-                               (cnf #f)
-                               (client-id #f)
-                               (other-fields '()))
-           (match payload
-             (()
-              (unless (and webid iss aud iat exp cnf client-id)
-                ;; Missing some things
-                (fail (format #f (G_ "the payload is missing ~s")
-                              `(,@(if webid '() '("webid"))
-                                ,@(if iss '() '("iss"))
-                                ,@(if aud '() '("aud"))
-                                ,@(if iat '() '("iat"))
-                                ,@(if exp '() '("exp"))
-                                ,@(if cnf '() '("cnf"))
-                                ,@(if client-id '() '("client_id"))))))
-              `(,header
-                . ((webid . ,(uri->string webid))
-                   (iss . ,(uri->string iss))
-                   (aud . "solid")
-                   (iat . ,(time-second (date->time-utc iat)))
-                   (exp . ,(time-second (date->time-utc exp)))
-                   (client_id . ,(uri->string client-id))
-                   (cnf . ,cnf)
-                   ,@(reverse other-fields))))
-             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
-              (examine-payload payload
-                               (or webid webid-given)
-                               iss aud iat exp cnf client-id other-fields))
-             ((('webid . infringing) payload ...)
-              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
-              (examine-payload payload webid
-                               (or iss iss-given)
-                               aud iat exp cnf client-id other-fields))
-             ((('iss . infringing) payload ...)
-              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('aud . "solid") payload ...)
-              (examine-payload payload webid iss #t iat exp cnf client-id other-fields))
-             ((('aud . infringing) payload ...)
-              (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given")
-                            infringing)))
-             ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...)
-              (examine-payload payload webid iss aud
-                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
-                               exp cnf client-id other-fields))
-             ((('iat . infringing) payload ...)
-              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
-                            infringing)))
-             ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...)
-              (examine-payload payload webid iss aud iat
-                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
-                               cnf client-id other-fields))
-             ((('exp . infringing) payload ...)
-              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
-                            infringing)))
-             ((('cnf . cnf) payload ...)
-              (let examine-cnf ((data cnf)
-                                (jkt #f)
-                                (other-cnf-fields '()))
-                (match data
-                  (()
-                   (unless jkt
-                     (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing"))))
-                   (examine-payload payload webid iss aud iat exp
-                                    `((jkt . ,jkt)
-                                      ,@(reverse other-cnf-fields))
-                                    client-id other-fields))
-                  ((('jkt . (? string? jkt-given)) data ...)
-                   (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields))
-                  ((('jkt . infringing) _ ...)
-                   (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given")
-                                 infringing)))
-                  ((field data ...)
-                   (examine-cnf data jkt `(,field ,@other-cnf-fields)))
-                  (data
-                   (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given")
-                                 data))))))
-             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
-              (examine-payload payload webid iss aud iat exp cnf
-                               (or client-id client-id-given)
-                               other-fields))
-             ((('client_id . infringing) payload ...)
-              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
-                            infringing)))
-             ((field payload ...)
-              (examine-payload payload webid iss aud iat exp cnf client-id
-                               `(,field ,@other-fields))))))
-        (else
-         (scm-error 'wrong-type-arg "the-access-token"
-                    "expected a pair of lists"
-                    '()
-                    (list x)))))))
-
-(define (access-token? x)
-  (false-if-exception (the-access-token x)))
-
-(define (access-token-alg code)
-  (match (the-access-token code)
-    ((header . _)
-     (string->symbol (assq-ref header 'alg)))))
-
-(define (access-token-webid code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'webid)))))
-
-(define (access-token-iss code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'iss)))))
+(define-class <access-token> (<time-bound-token> <oidc-token>)
+  (webid #:init-keyword #:webid #:accessor webid)
+  (aud #:init-keyword #:aud #:accessor aud)
+  (client-id #:init-keyword #:client-id #:accessor client-id)
+  (cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt))
 
-(define (access-token-aud code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (assq-ref payload 'aud))))
-
-(define (access-token-iat code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'iat))))))
-
-(define (access-token-exp code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'exp))))))
-
-(define (access-token-client-id code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'client-id)))))
-
-(define (access-token-cnf/jkt code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (assq-ref (assq-ref payload 'cnf) 'jkt))))
-
-(define* (access-token-decode str #:key (http-get http-get))
+(define-method (initialize (token <access-token>) initargs)
   (with-exception-handler
       (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the access token is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the access token is invalid")))))
-          (raise-exception
-           (make-exception
-            (make-invalid-access-token)
-            (make-exception-with-message final-message)
-            error))))
+        (raise-exception
+         (make-exception
+          (make-invalid-access-token)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid access token: ~a")
+                       (exception-message error))
+               (G_ "invalid access token")))
+          error)))
     (lambda ()
-      (jws-decode
-       str
-       (lambda (token)
-         (let* ((iss (access-token-iss token))
-                (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 configuratioon")))))
-                         (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 http-get))))
-                (jwks
-                 (with-exception-handler
-                     (lambda (error)
-                       (let ((final-message
-                              (if (exception-with-message? error)
-                                  (format #f (G_ "I cannot query the identity provider public keys: ~a")
-                                          (exception-message error))
-                                  (format #f (G_ "I cannot query the identity provider public keys")))))
-                         (raise-exception
-                          (make-exception
-                           (make-cannot-query-identity-provider iss)
-                           (make-exception-with-message final-message)
-                           error))))
-                   (lambda ()
-                     (oidc-configuration-jwks cfg #:http-get http-get)))))
-           (let ((iat (access-token-iat token))
-                 (exp (access-token-exp token))
-                 (current-date ((p:current-date))))
-             (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 access 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 access 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)))))))
-           jwks))))))
-
-(define (access-token-encode access-token key)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot encode the access token: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot encode the access token")))))
-          (raise-exception
-           (make-exception-with-message final-message))))
-    (lambda ()
-      (jws-encode access-token key))))
-
-(define* (issue-access-token
-          issuer-key
-          #:key
-          (webid #f)
-          (iss #f)
-          (validity 3600)
-          (client-key #f)
-          (cnf/jkt #f)
-          (client-id #f))
-  (when client-key
-    (set! cnf/jkt (jkt client-key)))
-  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
-         (exp (+ iat validity)))
-    (jws-encode
-     (the-access-token
-      `(((alg . ,(symbol->string (alg issuer-key))))
-        . ((webid . ,(uri->string webid))
-           (iss . ,(uri->string iss))
-           (aud . "solid")
-           (iat . ,iat)
-           (exp . ,exp)
-           (cnf . ((jkt . ,cnf/jkt)))
-           (client_id . ,(uri->string client-id)))))
-     issuer-key)))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((webid #f)
+        (aud "solid")
+        (client-id #f)
+        (cnf/jkt #f)
+        (client-key #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((webid webid)
+                           (aud aud)
+                           (client-id client-id)
+                           (cnf/jkt cnf/jkt)
+                           (client-key client-key)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? webid)
+           (do-initialize (string->uri webid)
+                          aud
+                          client-id
+                          cnf/jkt
+                          client-key
+                          jwt-header
+                          jwt-payload))
+          ((string? client-id)
+           (do-initialize webid
+                          aud
+                          (string->uri client-id)
+                          cnf/jkt
+                          client-key
+                          jwt-header
+                          jwt-payload))
+          ((and (not cnf/jkt) client-key)
+           (do-initialize webid aud client-id (jkt client-key) #f jwt-header jwt-payload))
+          ((and webid client-id cnf/jkt)
+           (unless (uri? webid)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:webid should be an URI")
+                        '()
+                        (list webid)))
+           (unless (uri? client-id)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:client-id should be an URI")
+                        '()
+                        (list client-id)))
+           (unless (string? cnf/jkt)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:cnf/jkt should be a string")
+                        '()
+                        (list cnf/jkt)))
+           (unless (equal? aud "solid")
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:aud should be exactly \"solid\"")
+                        '()
+                        (list aud)))
+           (slot-set! token 'webid webid)
+           (slot-set! token 'aud aud)
+           (slot-set! token 'client-id client-id)
+           (slot-set! token 'cnf/jkt cnf/jkt))
+          ((and jwt-header jwt-payload)
+           (do-initialize (assq-ref jwt-payload 'webid)
+                          (assq-ref jwt-payload 'aud)
+                          (assq-ref jwt-payload 'client_id)
+                          (assq-ref (assq-ref jwt-payload 'cnf) 'jkt)
+                          #f #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making an access token either its required fields (#:alg, #:webid, #:iss, #:aud, #:client-id, #:cnf/jkt, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <access-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     base-header
+     `((webid . ,(uri->string (webid token)))
+       (iss . ,(uri->string (iss token)))
+       (aud . ,(aud token))
+       (client_id . ,(uri->string (client-id token)))
+       (cnf . ((jkt . ,(cnf/jkt token))))
+       (iat . ,(time-second (date->time-utc (iat token))))
+       (exp . ,(time-second (date->time-utc (exp token))))
+       ,@base-payload))))