;; 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 oidc-id-token)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc jti)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc serializable)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-19)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:re-export
  (
   alg iat iss nonce
   token->jwt
   decode
   encode
   issue
   )
  #:export
  (
   &invalid-id-token
   make-invalid-id-token
   invalid-id-token?

   <id-token> webid sub aud
   ))

(define-exception-type
  &invalid-id-token
  &external-error
  make-invalid-id-token
  invalid-id-token?)

(define-class <id-token> (<single-use-token> <oidc-token>)
  (webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string)
  (sub #:init-keyword #:sub #:accessor sub)
  (aud #:init-keyword #:aud #:accessor aud #:->sxml uri->string)
  #:metaclass <plugin-class>
  #:module-name '(webid-oidc oidc-id-token))

(define-method (equal? (x <id-token>) (y <id-token>))
  (and (equal? (alg x) (alg y))
       (equal? (iat x) (iat y))
       (equal? ((@ (webid-oidc jws) exp) x) ((@ (webid-oidc jws) exp) y))
       (equal? (nonce x) (nonce y))
       (equal? (iss x) (iss y))))

(define-method (initialize (token <id-token>) initargs)
  (with-exception-handler
      (lambda (error)
        (raise-exception
         (make-exception
          (make-invalid-id-token)
          (make-exception-with-message
           (if (exception-with-message? error)
               (format #f (G_ "invalid OIDC ID token: ~a")
                       (exception-message error))
               (G_ "invalid OIDC id token")))
          error)))
    (lambda ()
      (next-method)
      (let-keywords
       initargs #t
       ((webid #f)
        (sub #f)
        (aud #f)
        (jwt-header #f)
        (jwt-payload #f))
       (let do-initialize ((webid webid)
                           (sub sub)
                           (aud aud)
                           (jwt-header jwt-header)
                           (jwt-payload jwt-payload))
         (cond
          ((string? webid)
           (do-initialize (string->uri webid) sub aud jwt-header jwt-payload))
          ((and (not sub) (uri? webid))
           (do-initialize webid (uri->string webid) aud jwt-header jwt-payload))
          ((string? aud)
           (do-initialize webid sub (string->uri aud) jwt-header jwt-payload))
          ((and webid sub)
           (unless (uri? webid)
             (scm-error 'wrong-type-arg "make"
                        (G_ "#:webid should be an URI")
                        '()
                        (list webid)))
           (unless (string? sub)
             (scm-error 'wrong-type-arg "make"
                        (G_ "#:sub should be a string")
                        '()
                        (list sub)))
           (unless (uri? aud)
             (scm-error 'wrong-type-arg "make"
                        (G_ "#:aud should be a string")
                        '()
                        (list aud)))
           (slot-set! token 'webid webid)
           (slot-set! token 'sub sub)
           (slot-set! token 'aud aud))
          ((and jwt-header jwt-payload)
           (do-initialize (assq-ref jwt-payload 'webid)
                          (assq-ref jwt-payload 'sub)
                          (assq-ref jwt-payload 'aud)
                          #f #f))
          (else
           (raise-exception
            (make-exception
             (make-invalid-jws)
             (make-exception-with-message
              (G_ "when making an ID token either its required fields (#:alg, #:webid, #:iss, #:sub, #:aud, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))

(define-method (token->jwt (token <id-token>))
  (receive (base-header base-payload)
      (next-method)
    (values
     base-header
     `((webid . ,(uri->string (webid token)))
       (sub . ,(sub token))
       (aud . ,(uri->string (aud token)))
       ,@base-payload))))