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

   &invalid-authorization-code
   make-invalid-authorization-code
   invalid-authorization-code?

   <authorization-code> webid client-id
   ))

(define-exception-type
  &invalid-authorization-code
  &external-error
  make-invalid-authorization-code
  invalid-authorization-code?)

(define-class <authorization-code> (<single-use-token>)
  (webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string)
  (client-id #:init-keyword #:client-id #:accessor client-id #:->sxml uri->string)
  #:module-name '(webid-oidc authorization-code))

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

(define-method (token->jwt (token <authorization-code>))
  (receive (base-header base-payload)
      (next-method)
    (values
     base-header
     `((webid . ,(uri->string (webid token)))
       (client_id . ,(uri->string (client-id token)))
       ,@base-payload))))

(define-method (lookup-keys (token <authorization-code>) args)
  (let-keywords
   args #f
   ((issuer-key #f))
   issuer-key))