JWS: use GOOPS

1 files changed, 79 insertions, 176 deletions

diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm
index 1481b2c..13b7ac4 100644
--- a/src/scm/webid-oidc/authorization-code.scm
+++ b/src/scm/webid-oidc/authorization-code.scm
@@ -26,7 +26,18 @@
   #:use-module (webid-oidc web-i18n)
   #:use-module (ice-9 match)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat exp nonce
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
 
@@ -34,18 +45,7 @@
    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
+   <authorization-code> webid client-id
    ))
 
 (define-exception-type
@@ -54,171 +54,74 @@
   make-invalid-authorization-code
   invalid-authorization-code?)
 
-(define (the-authorization-code 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 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 ()
-      (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-class <authorization-code> (<single-use-token>)
+  (webid #:init-keyword #:webid #:accessor webid)
+  (client-id #:init-keyword #:client-id #:accessor client-id))
 
-(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)
-          (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 (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)
+(define-method (initialize (token <authorization-code>) initargs)
   (with-exception-handler
       (lambda (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))))
+        (raise-exception
+         (make-exception
+          (make-invalid-authorization-code)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid authorization code: ~a")
+                       (exception-message error))
+               (G_ "invalid authorization code")))
+          error)))
     (lambda ()
-      (jws-encode authorization-code key))))
-
-(define* (issue-authorization-code issuer-key
-                                   #:key
-                                   (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 issuer-key))))
-       . ((webid . ,(uri->string webid))
-          (client_id . ,(uri->string client-id))
-          (exp . ,exp)
-          (jti . ,(stubs:random 12))))
-     issuer-key)))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((webid #f)
+        (client-id #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((webid webid)
+                           (client-id client-id)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? webid)
+           (do-initialize (string->uri webid) client-id jwt-header jwt-payload))
+          ((string? client-id)
+           (do-initialize webid (string->uri client-id) jwt-header jwt-payload))
+          ((and webid client-id)
+           (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 a string")
+                        '()
+                        (list client-id)))
+           (slot-set! token 'webid webid)
+           (slot-set! token 'client-id client-id))
+          ((and jwt-header jwt-payload)
+           (do-initialize (assq-ref jwt-payload 'webid)
+                          (assq-ref jwt-payload 'client_id)
+                          #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making an authorization code either its required fields (#:webid and #:client-id) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <authorization-code>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     base-header
+     `((webid . ,(uri->string (webid token)))
+       (client_id . ,(uri->string (client-id token)))
+       ,@base-payload))))
+
+(define-method (lookup-keys (token <authorization-code>) args)
+  (let-keywords
+   args #f
+   ((issuer-key #f))
+   issuer-key))