;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021  Vivien Kraus

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(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 ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-19)
  #:export
  (
   list-refresh-tokens
   update-refresh-token-list
   issue-refresh-token
   with-refresh-token
   remove-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))

(define (update-refresh-token-list f)
  (with-mutex mutex
    (let ((old (list-refresh-tokens)))
      (let ((new (f old)))
        (set-refresh-token-list new)))))

(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 (issue-refresh-token sub aud jkt)
  (define 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)))

(define (remove-refresh-token sub aud)
  (update-refresh-token-list (remove sub aud)))