Switch to a more sensible error reporting system

1 files changed, 142 insertions, 64 deletions

diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm
index e3fbf7c..14d7361 100644
--- a/src/scm/webid-oidc/refresh-token.scm
+++ b/src/scm/webid-oidc/refresh-token.scm
@@ -18,13 +18,33 @@
   #:use-module (webid-oidc errors)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (sxml simple)
+  #:use-module (sxml match)
+  #:declarative? #t
   #:export
   (
+   <refresh-token>
+   make-refresh-token
+   refresh-token?
+   refresh-token-sub
+   refresh-token-aud
+   refresh-token-jkt
+   refresh-token-refresh-token
+
+   &invalid-refresh-token
+   make-invalid-refresh-token
+   invalid-refresh-token?
+
    list-refresh-tokens
    update-refresh-token-list
    issue-refresh-token
@@ -32,83 +52,141 @@
    remove-refresh-token
    ))
 
+(define-exception-type
+  &invalid-refresh-token
+  &external-error
+  make-invalid-refresh-token
+  invalid-refresh-token?)
+
+(define-record-type <refresh-token>
+  (make-refresh-token sub aud jkt refresh-token)
+  refresh-token?
+  (sub refresh-token-sub)
+  (aud refresh-token-aud)
+  (jkt refresh-token-jkt)
+  (refresh-token refresh-token-refresh-token))
+
 (define (list-refresh-tokens)
-  (catch #t
-    (lambda ()
-      (with-input-from-file (format #f "~a/refresh-tokens.scm" (p:data-home))
-        read))
-    (lambda errors
-      '())))
-
-;; TODO: use stubs:atomically-update-file and remove that mutex.
-(define mutex (make-mutex))
-
-(define (set-refresh-token-list list)
-  (define dir (p:data-home))
-  (define old-file (format #f "~a/refresh-tokens.scm" dir))
-  (define new-file (format #f "~a/refresh-tokens.scm~" dir))
-  (stubs:call-with-output-file*
-   new-file
-   (lambda (port)
-     (write list port)
-     (close-port port)))
-  (rename-file new-file old-file))
+  (let generate-list
+      ((content
+        (catch #t
+          (lambda ()
+            (call-with-input-file (format #f "~a/refresh-tokens.xml" (p:data-home))
+              (cute xml->sxml <>
+                    #:namespaces '((disfluid
+                                    . "https://disfluid.planete-kraus.eu/refresh-token/v1")))))
+          (lambda error
+            '(*TOP* (disfluid:refresh-tokens)))))
+       (parsed-refresh-tokens '()))
+    (sxml-match
+     content
+     ((*TOP* (disfluid:refresh-tokens))
+      (reverse parsed-refresh-tokens))
+     ((*TOP* (disfluid:refresh-tokens
+              (disfluid:refresh-token
+               (@ (sub ,subject)
+                  (aud ,audience)
+                  (jkt ,jkt)
+                  (refresh-token ,refresh-token)))
+              ,other-refresh-tokens ...))
+      (let ((content
+             `(*TOP*
+               (disfluid:refresh-tokens
+                ,@other-refresh-tokens)))
+            (next-refresh-token
+             (make-refresh-token (string->uri subject)
+                                 (string->uri audience)
+                                 jkt
+                                 refresh-token)))
+        (generate-list content
+                       `(,next-refresh-token
+                         ,@parsed-refresh-tokens)))))))
 
-(define (update-refresh-token-list f)
-  (with-mutex mutex
-    (let ((old (list-refresh-tokens)))
-      (let ((new (f old)))
-        (set-refresh-token-list new)))))
+(define (update-refresh-token-list transformer)
+  (stubs:atomically-update-file
+   (format #f "~a/refresh-tokens.xml" (p:data-home))
+   (format #f "~a/refresh-tokens.xml.lock" (p:data-home))
+   (lambda (port)
+     (let* ((old-refresh-tokens (list-refresh-tokens))
+            (new-refresh-tokens (transformer old-refresh-tokens)))
+       (chmod port #o600)
+       (sxml->xml
+        `(*TOP*
+          (refresh-tokens
+           (@ (xmlns "https://disfluid.planete-kraus.eu/refresh-token/v1"))
+           ,@(map
+              (match-lambda
+                (($ <refresh-token>
+                    (= uri->string subject)
+                    (= uri->string audience)
+                    jkt
+                    refresh-token)
+                 `(refresh-token
+                   (@ (sub ,subject)
+                      (aud ,audience)
+                      (jkt ,jkt)
+                      (refresh-token ,refresh-token)))))
+              new-refresh-tokens)))
+        port)))))
 
 (define (remove sub aud)
+  (cute filter
+        (match-lambda
+          (($ <refresh-token>
+              (? (cute equal? <> sub) _)
+              (? (cute equal? <> aud) _)
+              _ _)
+           #f)
+          (else #t))
+        <>))
+
+(define (keep-n n)
   (lambda (old)
-    (filter (lambda (o)
-              (not (and (equal? (assq-ref o 'sub)
-                                (uri->string sub))
-                        (equal? (assq-ref o 'aud)
-                                (uri->string aud)))))
-            old)))
-
-(define (keep-n n list)
-  (cond
-   ((<= n 0) '())
-   ((null? list) '())
-   (else (cons (car list) (keep-n (- n 1) (cdr list))))))
+    (let start-at ((i 0) (data old) (kept '()))
+      (match data
+        (() (reverse kept))
+        ((saved data ...)
+         (if (>= i n)
+             (reverse kept)
+             (start-at (1+ i) data `(,saved ,@kept))))))))
 
 (define (insert sub aud jkt jti)
   (define remover (remove sub aud))
+  (define truncator (keep-n 20))
   (lambda (old)
-    (keep-n
-     20
-     (cons `((sub . ,(uri->string sub))
-             (aud . ,(uri->string aud))
-             (jkt . ,jkt)
-             (refresh_token . ,jti))
-           (remover old)))))
+    (truncator
+     `(,(make-refresh-token sub aud jkt jti)
+       ,@(remover old)))))
 
 (define (issue-refresh-token sub aud jkt)
-  (define jti (stubs:random 12))
-  (update-refresh-token-list (insert sub aud jkt jti))
-  jti)
+  (let ((jti (stubs:random 12)))
+    (update-refresh-token-list (insert sub aud jkt jti))
+    jti))
 
 (define (with-refresh-token refresh-token key f)
-  (let ((list (list-refresh-tokens)))
-    (define (check list)
-      (if (null? list)
-          (raise-invalid-refresh-token refresh-token)
-          (let ((hd (car list))
-                (tl (cdr list)))
-            (let ((sub (string->uri (assq-ref hd 'sub)))
-                  (aud (string->uri (assq-ref hd 'aud)))
-                  (cnf/jkt (assq-ref hd 'jkt))
-                  (the-refresh-token (assq-ref hd 'refresh_token)))
-              (if (string=? refresh-token the-refresh-token)
-                  (begin
-                    (unless (equal? (jkt key) cnf/jkt)
-                      (raise-invalid-key-for-refresh-token key cnf/jkt))
-                    (f sub aud))
-                  (check tl))))))
-    (check list)))
+  (let search ((tokens (list-refresh-tokens)))
+    (match tokens
+      (()
+       (let ((final-message
+              (format #f (G_ "the refresh token does not exist"))))
+         (raise-exception
+          (make-exception
+           (make-invalid-refresh-token)
+           (make-exception-with-message final-message)))))
+      ((($ <refresh-token> (? uri? sub) (? uri? aud) (? string? the-jkt) (? string? the-rft))
+        tokens ...)
+       (if (equal? refresh-token the-rft)
+           (begin
+             (unless (equal? (jkt key) the-jkt)
+               (let ((final-message 
+                      (format #f (G_ "the refresh token is bound to key ~s, which is not that one")
+                              the-jkt)))
+                 (raise-exception
+                  (make-exception
+                   (make-invalid-refresh-token)
+                   (make-exception-with-message final-message)))))
+             (f sub aud))
+           (search tokens))))))
 
 (define (remove-refresh-token sub aud)
   (update-refresh-token-list (remove sub aud)))