;; webid-oidc, 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 authorization-code)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc jti)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (srfi srfi-19))

(define-public (the-authorization-code-header x)
  (with-exception-handler
      (lambda (error)
        (raise-not-an-authorization-code-header x error))
    (lambda ()
      (the-jws-header x))))

(define-public (authorization-code-header? x)
  (false-if-exception
   (and (the-authorization-code-header x) #t)))

(define-public (the-authorization-code-payload x)
  (with-exception-handler
      (lambda (error)
        (raise-not-an-authorization-code-payload x error))
    (lambda ()
      (let ((x (the-jws-payload x)))
        (let ((exp (assq-ref x 'exp))
              (jti (assq-ref x 'jti))
              (webid (assq-ref x 'webid))
              (client-id (assq-ref x 'client_id)))
          (unless (integer? exp)
            (raise-incorrect-exp-field exp))
          (unless (string? jti)
            (raise-incorrect-jti-field jti))
          (unless (and (string? webid) (string->uri webid))
            (raise-incorrect-webid-field webid))
          (unless (and (string? client-id) (string->uri client-id))
            (raise-incorrect-client-id-field client-id))
          x)))))

(define-public (authorization-code-payload? x)
  (false-if-exception
   (and (the-authorization-code-payload x) #t)))

(define-public (the-authorization-code x)
  (with-exception-handler
      (lambda (error)
        (raise-not-an-authorization-code x error))
    (lambda ()
      (cons (the-authorization-code-header (car x))
            (the-authorization-code-payload (cdr x))))))

(define-public (authorization-code? x)
  (false-if-exception
   (and (the-authorization-code x) #t)))

(define-public (make-authorization-code header payload)
  (the-authorization-code (cons header payload)))

(define-public (make-authorization-code-header alg)
  (when (symbol? alg)
    (set! alg (symbol->string alg)))
  (the-authorization-code-header
   `((alg . ,alg))))

(define-public (make-authorization-code-payload exp jti sub aud)
  (when (date? exp)
    (set! exp (date->time-utc exp)))
  (when (time? exp)
    (set! exp (time-second exp)))
  (when (uri? sub)
    (set! sub (uri->string sub)))
  (when (uri? aud)
    (set! aud (uri->string aud)))
  (the-authorization-code-payload
   `((exp . ,exp)
     (jti . ,jti)
     (webid . ,sub)
     (client_id . ,aud))))

(define-public (authorization-code-header code)
  (car (the-authorization-code code)))

(define-public (authorization-code-payload code)
  (cdr (the-authorization-code code)))

(define-public (authorization-code-alg code)
  (when (authorization-code? code)
    (set! code (authorization-code-header code)))
  (jws-alg (the-authorization-code-header code)))

(define-public (authorization-code-exp code)
  (when (authorization-code? code)
    (set! code (authorization-code-payload code)))
  (time-utc->date
   (make-time time-utc 0 (assq-ref
                          (the-authorization-code-payload code)
                          'exp))))

(define-public (authorization-code-jti code)
  (when (authorization-code? code)
    (set! code (authorization-code-payload code)))
  (assq-ref (the-authorization-code-payload code) 'jti))

(define-public (authorization-code-webid code)
  (when (authorization-code? code)
    (set! code (authorization-code-payload code)))
  (string->uri
   (assq-ref (the-authorization-code-payload code) 'webid)))

(define-public (authorization-code-client-id code)
  (when (authorization-code? code)
    (set! code (authorization-code-payload code)))
  (string->uri
   (assq-ref (the-authorization-code-payload code) 'client_id)))

(define-public (authorization-code-decode str jwk)
  (parameterize ((p:current-date
                  (time-second (date->time-utc ((p:current-date))))))
    (with-exception-handler
        (lambda (error)
          (raise-cannot-decode-authorization-code str error))
      (lambda ()
        (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk)))))
          (let ((exp (time-second (date->time-utc (authorization-code-exp code))))
                (current-time (time-second (date->time-utc ((p:current-date))))))
            (unless (<= current-time exp)
              (raise-authorization-code-expired exp current-time))
            (unless (jti-check (authorization-code-jti code)
                               (- exp current-time))
              (with-exception-handler
                  (lambda (error)
                    (raise-jti-found (authorization-code-jti code) error))
                (lambda ()
                  (error "the jti-check function returned #f"))))
            code))))))

(define-public (authorization-code-encode authorization-code key)
  (with-exception-handler
      (lambda (error)
        (raise-cannot-encode-authorization-code authorization-code key error))
    (lambda ()
      (jws-encode authorization-code key))))

(define-public (issue-authorization-code alg jwk exp sub aud)
  (authorization-code-encode
   (make-authorization-code
    (make-authorization-code-header alg)
    (make-authorization-code-payload exp (stubs:random 12) sub aud))
   jwk))