;; 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 access-token)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-19))

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

(define-public (access-token-header? x)
  (false-if-exception
   (and (the-access-token-header x) #t)))

(define-public (the-access-token-payload x)
  (with-exception-handler
      (lambda (error)
        (raise-not-an-access-token-payload x error))
    (lambda ()
      (let ((x (the-jws-payload x)))
        (let ((webid (assq-ref x 'webid))
              (iss (assq-ref x 'iss))
              (aud (assq-ref x 'aud))
              (iat (assq-ref x 'iat))
              (exp (assq-ref x 'exp))
              (cnf (assq-ref x 'cnf))
              (client-id (assq-ref x 'client_id)))
          (unless (and webid (string? webid) (string->uri webid))
            (raise-incorrect-webid-field webid))
          (unless (and iss (string? iss) (string->uri iss))
            (raise-incorrect-iss-field iss))
          (unless (equal? aud "solid")
            (raise-incorrect-aud-field aud))
          (unless (integer? iat)
            (raise-incorrect-iat-field iat))
          (unless (and (integer? exp) (>= exp iat))
            (raise-incorrect-exp-field exp))
          (unless (and client-id (string? client-id) (string->uri client-id))
            (raise-incorrect-client-id-field client-id))
          (unless (and cnf (assq-ref cnf 'jkt) (string? (assq-ref cnf 'jkt)))
            (raise-incorrect-cnf/jkt-field (and cnf (assq-ref cnf 'jkt))))
          x)))))

(define-public (access-token-payload? x)
  (false-if-exception
   (and (the-access-token-header x) #t)))

(define-public (the-access-token x)
  (with-exception-handler
      (lambda (cause)
        (raise-not-an-access-token x cause))
    (lambda ()
      (cons (the-access-token-header (car x))
            (the-access-token-payload (cdr x))))))

(define-public (access-token? x)
  (false-if-exception
   (and (the-access-token x) #t)))

(define-public (make-access-token header payload)
  (the-access-token
   (cons header payload)))

(define-public (make-access-token-payload webid iss iat exp cnf/jkt client-id)
  (when (date? exp)
    (set! exp (date->time-utc exp)))
  (when (time? exp)
    (set! exp (time-second exp)))
  (when (date? iat)
    (set! iat (date->time-utc iat)))
  (when (time? iat)
    (set! iat (time-second iat)))
  (when (uri? webid)
    (set! webid (uri->string webid)))
  (when (uri? iss)
    (set! iss (uri->string iss)))
  (when (uri? client-id)
    (set! client-id (uri->string client-id)))
  (the-access-token-payload
   `((webid . ,webid)
     (iss . ,iss)
     (aud . "solid")
     (iat . ,iat)
     (exp . ,exp)
     (cnf . ((jkt . ,cnf/jkt)))
     (client_id . ,client-id))))

(define-public (access-token-header code)
  (car (the-access-token code)))

(define-public (access-token-payload code)
  (cdr (the-access-token code)))

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

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

(define-public (access-token-iss code)
  (when (access-token? code)
    (set! code (access-token-payload code)))
  (string->uri
   (assq-ref (the-access-token-payload code) 'iss)))

(define-public (access-token-aud code)
  (when (access-token? code)
    (set! code (access-token-payload code)))
  (assq-ref (the-access-token-payload code) 'aud))

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

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

(define-public (access-token-cnf/jkt code)
  (when (access-token? code)
    (set! code (access-token-payload code)))
  (assq-ref
   (assq-ref (the-access-token-payload code) 'cnf)
   'jkt))

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

(define*-public (access-token-decode str #:key (http-get http-get))
  (with-exception-handler
      (lambda (error)
        (raise-cannot-decode-access-token str error))
    (lambda ()
      (jws-decode
       str
       (lambda (token)
         (let ((iss (access-token-iss token)))
           (let ((cfg
                  (with-exception-handler
                      (lambda (error)
                        (raise-cannot-fetch-issuer-configuration iss error))
                    (lambda ()
                      (get-oidc-configuration
                       (uri-host iss)
                       #:userinfo (uri-userinfo iss)
                       #:port (uri-port iss)
                       #:http-get http-get)))))
             (with-exception-handler
                 (lambda (error)
                   (raise-cannot-fetch-jwks iss
                                            (oidc-configuration-jwks-uri cfg)
                                            error))
               (lambda ()
                 (oidc-configuration-jwks cfg #:http-get http-get))))))))))

(define-public (access-token-encode access-token key)
  (with-exception-handler
      (lambda (error)
        (raise-cannot-encode-access-token access-token key error))
    (lambda ()
      (jws-encode access-token key))))

(define*-public (issue-access-token
                 issuer-key
                 #:key
                 (alg #f)
                 (webid #f)
                 (iss #f)
                 (iat #f)
                 (exp #f)
                 (client-key #f)
                 (cnf/jkt #f)
                 (client-id #f))
  (when client-key
    (set! cnf/jkt (jkt client-key)))
  (access-token-encode
   (make-access-token
    `((alg . ,(if (symbol? alg) (symbol->string alg) alg)))
    (make-access-token-payload
     webid iss iat exp cnf/jkt client-id))
   issuer-key))