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

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

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

(define-public (the-id-token-payload x)
  (with-exception-handler
      (lambda (error)
        (raise-not-an-id-token-payload x error))
    (lambda ()
      (let ((x (the-jws-payload x)))
        (let ((webid (assq-ref x 'webid))
              (iss (assq-ref x 'iss))
              (sub (assq-ref x 'sub))
              (aud (assq-ref x 'aud))
              (nonce (assq-ref x 'nonce))
              (iat (assq-ref x 'iat))
              (exp (assq-ref x 'exp)))
          (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 (string? sub)
            (raise-incorrect-sub-field sub))
          (unless (and aud (string? aud) (string->uri aud))
            (raise-incorrect-aud-field aud))
          (unless (string? nonce)
            (raise-incorrect-nonce-field nonce))
          (unless (integer? iat)
            (raise-incorrect-iat-field iat))
          (unless (and (integer? exp) (>= exp iat))
            (raise-incorrect-exp-field exp))
          x)))))

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

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

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

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

(define-public (make-id-token-payload webid iss sub aud nonce exp iat)
  (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? aud)
    (set! aud (uri->string aud)))
  (the-id-token-payload
   `((webid . ,webid)
     (iss . ,iss)
     (sub . ,sub)
     (aud . ,aud)
     (nonce . ,nonce)
     (exp . ,exp)
     (iat . ,iat))))

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

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

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

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

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

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

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

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

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

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

(define*-public (id-token-decode str #:key (http-get http-get))
  (with-exception-handler
      (lambda (error)
        (raise-cannot-decode-id-token str error))
    (lambda ()
      (jws-decode
       str
       (lambda (token)
         (let ((iss (id-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 (id-token-encode id-token key)
  (with-exception-handler
      (lambda (error)
        (raise-cannot-encode-id-token id-token key error))
    (lambda ()
      (jws-encode id-token key))))

(define*-public (issue-id-token
                 issuer-key
                 #:key
                 (alg #f)
                 (webid #f)
                 (iss #f)
                 (sub #f)
                 (aud #f)
                 (validity 3600))
  (unless sub
    (set! sub webid))
  (id-token-encode
   (make-id-token
    `((alg . ,(symbol->string alg)))
    (let ((iat (time-second (date->time-utc ((p:current-date))))))
      (make-id-token-payload webid iss sub aud (stubs:random 12)
                             (+ iat validity) iat)))
   issuer-key))