;; 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 jwk)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc errors)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-19)
  #:use-module (web response)
  #:use-module (web client)
  #:use-module (rnrs bytevectors))

(define-public (the-jwk x)
  (with-exception-handler
      (lambda (cause)
        (raise-not-a-jwk x cause))
    (lambda ()
      (let ((kty (stubs:kty x)))
        (unless (or (eq? kty 'EC) (eq? kty 'RSA))
          (throw 'really-not-a-jwk))
        x))))

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

(define-public (kty x)
  (stubs:kty (the-jwk x)))

(define-public (the-public-jwk x)
  (with-exception-handler
      (lambda (cause)
        (raise-not-a-public-jwk x cause))
    (lambda ()
      (let ((key (the-jwk x)))
        (let ((crv (assq-ref key 'crv))
              (x (assq-ref key 'x))
              (y (assq-ref key 'y))
              (n (assq-ref key 'n))
              (e (assq-ref key 'e)))
          (let ((ec-part `((crv . ,crv)
                           (x . ,x)
                           (y . ,y)))
                (rsa-part `((n . ,n)
                            (e . ,e))))
            (case (stubs:kty key)
              ((EC) ec-part)
              ((RSA) rsa-part))))))))

(define-public (jwk-public? key)
  (false-if-exception
   (and (the-public-jwk key) #t)))

(define-public (strip key)
  (with-exception-handler
      (lambda (cause)
        (raise-not-a-public-jwk key cause))
    (lambda ()
      (stubs:strip-key key))))

(define-public (jkt x)
  (stubs:jkt (the-public-jwk x)))

(define-public (make-rsa-public-key n e)
  (the-public-jwk
   `((n . ,n)
     (e . ,e))))

(define-public (make-rsa-private-key d p q dp dq qi)
  (the-jwk
   `((d . ,d)
     (p . ,p)
     (q . ,q)
     (dp . ,dp)
     (dq . ,dq)
     (qi . ,qi))))

(define-public (make-ec-point crv x y)
  (if (symbol? crv)
      (make-ec-point (symbol->string crv) x y)
      (the-public-jwk
       `((crv . ,crv)
         (x . ,x)
         (y . ,y)))))

(define-public (make-ec-scalar crv d)
  (if (symbol? crv)
      (make-ec-scalar (symbol->string crv) d)
      (the-jwk
       `((crv . ,crv)
         (d . ,d)))))

(define-public generate-key stubs:generate-key)

(define (the-public-keys keys)
  (map the-public-jwk keys))

(define-public (the-jwks jwks)
  (let ((keys (vector->list (assoc-ref jwks 'keys))))
    (unless keys
      (raise-not-a-jwks jwks #f))
    (with-exception-handler
        (lambda (cause)
          (raise-not-a-jwks jwks cause))
      (lambda ()
        `((keys . ,(list->vector (the-public-keys keys))))))))

(define-public (jwks? jwks)
  (false-if-exception
   (and (the-jwks jwks) #t)))

(define-public (make-jwks keys)
  (if (vector? keys)
      (make-jwks (vector->list keys))
      (let ((pubs (list->vector (map strip keys))))
        (the-jwks `((keys . ,pubs))))))

(define-public (jwks-keys jwks)
  (vector->list (assq-ref (the-jwks jwks) 'keys)))

(define-public (serve-jwks expiration-date jwks)
  (values (build-response
           #:headers `((content-type . (application/json))
                       (expires . ,expiration-date)))
          (stubs:scm->json-string (the-jwks jwks))))

(define*-public (get-jwks uri #:key (http-get http-get))
  (receive (response response-body) (http-get uri)
    (with-exception-handler
        (lambda (cause)
          (raise-unexpected-response response cause))
      (lambda ()
        (unless (eqv? (response-code response) 200)
          (raise-request-failed-unexpectedly
           (response-code response)
           (response-reason-phrase response)))
        (let ((content-type (response-content-type response)))
          (unless content-type
            (raise-unexpected-header-value 'content-type content-type))
          (unless (and (eq? (car content-type) 'application/json)
                       (or (equal? (assoc-ref (cdr content-type) 'charset)
                                   "utf-8")
                           (not (assoc-ref (cdr content-type) 'charset))))
            (raise-unexpected-header-value 'content-type content-type))
          (unless (string? response-body)
            (set! response-body (utf8->string response-body)))
          (the-jwks (stubs:json-string->scm response-body)))))))