;; 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 (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/disfluid" 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))