;; 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 oidc-configuration)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc jti)
  #:use-module (webid-oidc web-i18n)
  #: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 (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-19)
  #:declarative? #t
  #:export
  (
   &invalid-id-token
   make-invalid-id-token
   invalid-id-token?

   the-id-token
   id-token?

   id-token-alg
   id-token-webid
   id-token-iss
   id-token-sub
   id-token-aud
   id-token-nonce
   id-token-iat
   id-token-exp

   id-token-decode
   issue-id-token
   ))

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

(define (the-id-token x)
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (cond
                ((and (invalid-jws? error)
                      (exception-with-message? error))
                 (format #f (G_ "this is not an ID token, because it is not even a JWS: ~a")
                         (exception-message error)))
                ((invalid-jws? error)
                 (format #f (G_ "this is not an ID token, because it is not even a JWS")))
                ((exception-with-message? error)
                 (format #f (G_ "this is not an ID token: ~a")
                         (exception-message error)))
                (else
                 (format #f (G_ "this is not an ID token"))))))
          (raise-exception
           (make-exception
            (make-invalid-id-token)
            (make-exception-with-message final-message)
            error))))
    (lambda ()
      (match (the-jws x)
        ((header . payload)
         (let examine-payload ((payload payload)
                               (webid #f)
                               (iss #f)
                               (sub #f)
                               (aud #f)
                               (nonce #f)
                               (iat #f)
                               (exp #f)
                               (other-fields '()))
           (match payload
             (()
              (unless (and webid iss sub aud nonce iat exp)
                (fail (format #f (G_ "the payload is missing ~s")
                              `(,@(if webid '() '("webid"))
                                ,@(if iss '() '("iss"))
                                ,@(if sud '() '("sub"))
                                ,@(if aud '() '("aud"))
                                ,@(if nonce '() '("nonce"))
                                ,@(if iat '() '("iat"))
                                ,@(if exp '() '("exp"))))))
              `(,header
                . ((webid . ,(uri->string webid))
                   (iss . ,(uri->string iss))
                   (sub . ,sub)
                   (aud . ,(uri->string aud))
                   (nonce . ,nonce)
                   (iat . ,(time-second (date->time-utc iat)))
                   (exp . ,(time-second (date->time-utc exp))))))
             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
              (examine-payload payload
                               (or webid webid-given)
                               iss sub aud nonce iat exp other-fields))
             ((('webid . invalid) payload ...)
              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
                            invalid)))
             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
              (examine-payload payload webid
                               (or iss iss-given)
                               sub aud nonce iat exp other-fields))
             ((('iss . invalid) payload ...)
              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
                            invalid)))
             ((('sub . (? string? sub-given)) payload ...)
              (examine-payload payload webid iss
                               (or sub sub-given)
                               aud nonce iat exp other-fields))
             ((('sub . invalid) payload ...)
              (fail (format #f (G_ "the \"sub\" field should be a string, ~s is given")
                            invalid)))
             ((('aud . (? string? (= string->uri (? uri? aud-given)))) payload ...)
              (examine-payload payload webid iss sub
                               (or aud aud-given)
                               nonce iat exp other-fields))
             ((('aud . invalid) payload ...)
              (fail (format #f (G_ "the \"aud\" field should be an URI, ~s is given")
                            invalid)))
             ((('nonce . (? string? nonce-given)) payload ...)
              (examine-payload payload webid iss sub aud
                               (or nonce nonce-given)
                               iat exp other-fields))
             ((('nonce . invalid) payload ...)
              (fail (format #f (G_ "the \"nonce\" field should be a string, ~s is given")
                            invalid)))
             ((('iat . (? (lambda (x) (>= x 0)) (? integer? iat-given))) payload ...)
              (examine-payload payload webid iss sub aud nonce
                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
                               exp other-fields))
             ((('iat . invalid) payload ...)
              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
                            invalid)))
             ((('exp . (? (lambda (x) (>= x 0)) (? integer? exp-given))) payload ...)
              (examine-payload payload webid iss sub aud nonce iat
                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
                               other-fields))
             ((('exp . invalid) payload ...)
              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
                            invalid)))
             ((field payload ...)
              (examine-payload payload webid iss sub aud nonce iat exp
                               `(,field ,@other-fields)))
             (else
              (fail (format #f (G_ "the payload should be a JSON object")))))))))))

(define (id-token? x)
  (false-if-exception
   (the-id-token x)))

(define (id-token-alg code)
  (match (the-id-token code)
    ((header . _)
     (string->symbol (assq-ref header 'alg)))))

(define (id-token-webid code)
  (match (the-id-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'webid)))))

(define (id-token-iss code)
  (match (the-id-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'iss)))))

(define (id-token-sub code)
  (match (the-id-token code)
    ((_ . payload)
     (assq-ref payload 'sub))))

(define (id-token-aud code)
  (match (the-id-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'aud)))))

(define (id-token-nonce code)
  (match (the-id-token code)
    ((_ . payload)
     (assq-ref payload 'nonce))))

(define (id-token-iat code)
  (match (the-id-token code)
    ((_ . payload)
     (time-utc->date
      (make-time time-utc 0 (assq-ref payload 'iat))))))

(define (id-token-exp code)
  (match (the-id-token code)
    ((_ . payload)
     (time-utc->date
      (make-time time-utc 0 (assq-ref payload 'exp))))))

(define* (id-token-decode str #:key (http-get http-get))
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (if (exception-with-message? error)
                   (format #f (G_ "the ID token is invalid: ~a")
                           (exception-message error))
                   (format #f (G_ "the ID token is invalid")))))
          (raise-exception
           (make-exception
            (make-invalid-id-token)
            (make-exception-with-message final-message)
            error))))
    (lambda ()
      (jws-decode
       str
       (lambda (token)
         (let ((iss (id-token-iss token)))
           (let* ((cfg
                   (with-exception-handler
                       (lambda (error)
                         (let ((final-message
                                (if (exception-with-message? error)
                                    (format #f (G_ "I cannot query the identity provider configuration: ~a")
                                            (exception-message error))
                                    (format #f (G_ "I cannot query the identity provider configuratioon")))))
                           (raise-exception
                            (make-exception
                             (make-cannot-query-identity-provider iss)
                             (make-exception-with-message final-message)
                             error))))
                     (lambda ()
                       (get-oidc-configuration
                        (uri-host iss)
                        #:userinfo (uri-userinfo iss)
                        #:port (uri-port iss)
                        #:http-get http-get))))
                  (jwks
                   (with-exception-handler
                       (lambda (error)
                         (raise-exception
                          (make-exception
                           (make-cannot-query-identity-provider iss)
                           (make-exception-with-message
                            (if (exception-with-message? error)
                                (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a")
                                        (exception-message error))
                                (format #f (G_ "I cannot query the JWKS URI of the identity provider")))))))
                     (lambda ()
                       (oidc-configuration-jwks cfg #:http-get http-get)))))
             (let ((iat (id-token-iat token))
                   (exp (id-token-exp token))
                   (current-date ((p:current-date))))
               (let ((iat-s (time-second (date->time-utc iat)))
                     (exp-s (time-second (date->time-utc exp)))
                     (current-s (time-second (date->time-utc current-date))))
                 (when (>= iat-s (+ current-s 5))
                   (let ((final-message
                          (format #f (G_ "the ID token is signed in the future, ~a, relative to current ~a")
                                  (date->string iat)
                                  (date->string current-date))))
                     (raise-exception
                      (make-exception
                       (make-signed-in-future iat current-date)
                       (make-exception-with-message final-message)))))
                 (when (>= current-s exp-s)
                   (let ((final-message
                          (format #f (G_ "the ID token expired ~a, which is in the past (from ~a)")
                                  (date->string exp)
                                  (date->string current-date))))
                     (raise-exception
                      (make-exception
                       (make-expired exp current-date)
                       (make-exception-with-message final-message)))))))
             jwks)))))))

(define (id-token-encode id-token key)
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (if (exception-with-message? error)
                   (format #f (G_ "cannot encode the ID token: ~a")
                           (exception-message error))
                   (format #f (G_ "cannot encode the ID token")))))
          (raise-exception
           (make-exception-with-message final-message))))
    (lambda ()
      (jws-encode id-token key))))

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