;; 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 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
   with-refresh-token
   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)
  (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 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)
    (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)
    (truncator
     `(,(make-refresh-token sub aud jkt jti)
       ,@(remover old)))))

(define (issue-refresh-token sub aud jkt)
  (let ((jti (stubs:random 12)))
    (update-refresh-token-list (insert sub aud jkt jti))
    jti))

(define (with-refresh-token refresh-token key f)
  (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)))