1 files changed, 111 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm
new file mode 100644
index 0000000..d2a7da6
--- /dev/null
+++ b/src/scm/webid-oidc/refresh-token.scm
@@ -0,0 +1,111 @@
+(define-module (webid-oidc refresh-token)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (webid-oidc jwk)
+  #:use-module (web uri)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-19))
+
+(define-public (default-dir)
+  (let ((xdg-data-home (or
+                        (getenv "XDG_DATA_HOME")
+                        (format #f "~a/.local/share"
+                                (getenv "HOME")))))
+    (format #f "~a/webid-oidc" xdg-data-home)))
+
+(define*-public (list-refresh-tokens
+                 #:key
+                 (dir default-dir))
+  (when (thunk? dir)
+    (set! dir (dir)))
+  (catch #t
+    (lambda ()
+      (with-input-from-file (format #f "~a/refresh-tokens.scm" dir)
+        read))
+    (lambda errors
+      '())))
+
+(define mutex (make-mutex))
+
+(define* (set-refresh-token-list list
+                                 #:key (dir default-dir))
+  (when (thunk? dir)
+    (set! dir (dir)))
+  (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))
+
+(define*-public (update-refresh-token-list f
+                                           #:key (dir default-dir))
+  (with-mutex mutex
+    (let ((old (list-refresh-tokens #:dir dir)))
+      (let ((new (f old)))
+        (set-refresh-token-list new #:dir dir)))))
+
+(define (remove sub aud)
+  (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))))))
+
+(define (insert sub aud jkt jti)
+  (define remover (remove sub aud))
+  (lambda (old)
+    (keep-n
+     20
+     (cons `((sub . ,(uri->string sub))
+             (aud . ,(uri->string aud))
+             (jkt . ,jkt)
+             (refresh_token . ,jti))
+           (remover old)))))
+
+(define*-public (issue-refresh-token sub aud jkt
+                                     #:key
+                                     (dir default-dir))
+  (define jti (stubs:random 12))
+  (update-refresh-token-list (insert sub aud jkt jti)
+                             #:dir dir)
+  jti)
+
+(define*-public (with-refresh-token refresh-token
+                                    key
+                                    f
+                                    #:key
+                                    (dir default-dir))
+  (let ((list (list-refresh-tokens #:dir dir)))
+    (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)))
+
+(define*-public (remove-refresh-token sub aud
+                                      #:key
+                                      (dir default-dir))
+  (update-refresh-token-list (remove sub aud) #:dir dir))