Add the refresh token code

4 files changed, 148 insertions, 7 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 6736595..d18d5fc 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -11,7 +11,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/dpop-proof.scm \
   %reldir%/fetch.scm \
   %reldir%/client-manifest.scm \
-  %reldir%/authorization-code.scm
+  %reldir%/authorization-code.scm \
+  %reldir%/refresh-token.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -25,4 +26,5 @@ webidoidcgo_DATA += \
   %reldir%/dpop-proof.go \
   %reldir%/fetch.go \
   %reldir%/client-manifest.go \
-  %reldir%/authorization-code.go
+  %reldir%/authorization-code.go \
+  %reldir%/refresh-token.go
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 879b23c..e8ab5af 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -687,6 +687,26 @@
   (raise-exception
    ((record-constructor &cannot-encode-authorization-code) authorization-code key cause)))
 
+(define-public &invalid-refresh-token
+  (make-exception-type
+   '&invalid-refresh-token
+   &external-error
+   '(refresh-token)))
+
+(define-public (raise-invalid-refresh-token refresh-token)
+  (raise-exception
+   ((record-constructor &invalid-refresh-token) refresh-token)))
+
+(define-public &invalid-key-for-refresh-token
+  (make-exception-type
+   '&invalid-key-for-refresh-token
+   &external-error
+   '(key jkt)))
+
+(define-public (raise-invalid-key-for-refresh-token key jkt)
+  (raise-exception
+   ((record-constructor &invalid-key-for-refresh-token) key jkt)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -956,16 +976,22 @@
           ((&not-an-authorization-code-payload)
            (format #f (G_ "~s is not an authorization code payload (because ~a)")
                    (get 'value) (recurse (get 'cause))))
-	  ((&authorization-code-expired)
-	   (format #f (G_ "the current time is ~a, and the authorization code expired at ~a")
-		   (time-second (date->time-utc (get 'current-time)))
-		   (time-second (date->time-utc (get 'exp)))))
+          ((&authorization-code-expired)
+           (format #f (G_ "the current time is ~a, and the authorization code expired at ~a")
+                   (time-second (date->time-utc (get 'current-time)))
+                   (time-second (date->time-utc (get 'exp)))))
           ((&cannot-decode-authorization-code)
            (format #f (G_ "I cannot decode ~s as an authorization code (because ~a)")
                    (get 'value) (recurse (get 'cause))))
           ((&cannot-encode-authorization-code)
            (format #f (G_ "I cannot encode ~s as an authorization code (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&invalid-refresh-token)
+           (format #f (G_ "there is no such refresh token as ~s")
+                   (get 'refresh-token)))
+          ((&invalid-key-for-refresh-token)
+           (format #f (G_ "the refresh token is bound to a key confirmed as ~s, but it is used with key ~s")
+                   (get 'jkt) (get 'key)))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
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))
diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm
index d4b7f4d..aecb2a3 100644
--- a/src/scm/webid-oidc/testing.scm
+++ b/src/scm/webid-oidc/testing.scm
@@ -5,8 +5,10 @@
 ;; This module is used only when running tests.
 
 (define-public (with-test-environment test-name f)
-  (let ((cache-dir (format #f "tests/~a.cache" test-name)))
+  (let ((cache-dir (format #f "tests/~a.cache" test-name))
+        (data-dir (format #f "tests/~a.home" test-name)))
     (setenv "XDG_CACHE_HOME" cache-dir)
+    (setenv "XDG_DATA_HOME" data-dir)
     (catch #t
       (lambda () (mkdir cache-dir))
       (lambda err #t))