(define-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs))

(define-public (the-oidc-configuration x)
  (with-exception-handler
      (lambda (cause)
        (raise-not-an-oidc-configuration x cause))
    (lambda ()
      (let ((jwks-uri (assq-ref x 'jwks_uri))
            (token-endpoint (assq-ref x 'token_endpoint))
            (authorization-endpoint (assq-ref x 'authorization_endpoint)))
        (unless jwks-uri
          (raise-missing-alist-key x 'jwks_uri))
        (unless token-endpoint
          (raise-missing-alist-key x 'token_endpoint))
        (unless authorization-endpoint
          (raise-missing-alist-key x 'authorization_endpoint))
        (for-each
         (lambda (field)
           (unless (string->uri field)
             (scm-error 'wrong-type-arg
                        "the-oidc-configuration"
                        "expected an uri-like string"
                        '()
                        (list field))))
         (list jwks-uri token-endpoint authorization-endpoint))
        x))))

(define-public (oidc-configuration? obj)
  (false-if-exception
   (and (the-oidc-configuration obj) obj)))

(define-public (make-oidc-configuration jwks-uri
                                        authorization-endpoint
                                        token-endpoint)
  (when (string? jwks-uri)
    (set! jwks-uri (string->uri jwks-uri)))
  (when (string? authorization-endpoint)
    (set! authorization-endpoint (string->uri authorization-endpoint)))
  (when (string? token-endpoint)
    (set! token-endpoint (string->uri token-endpoint)))
  (the-oidc-configuration
   `((jwks_uri . ,(uri->string jwks-uri))
     (token_endpoint . ,(uri->string token-endpoint))
     (authorization_endpoint . ,(uri->string authorization-endpoint)))))

(define (uri-field what)
  (lambda (x)
    (let ((str (assq-ref (the-oidc-configuration x) what)))
      (string->uri str))))

(define-public oidc-configuration-jwks-uri
  (uri-field 'jwks_uri))

(define-public oidc-configuration-authorization-endpoint
  (uri-field 'authorization_endpoint))

(define-public oidc-configuration-token-endpoint
  (uri-field 'token_endpoint))

(define-public (oidc-configuration-jwks cfg . args)
  (apply get-jwks (oidc-configuration-jwks-uri cfg) args))

(define-public (serve-oidc-configuration expiration-date cfg)
  (let ((with-solid-oidc-supported
         (acons 'solid_oidc_supported "https://solidproject.org/TR/solid-oidc"
                (the-oidc-configuration cfg))))
    (values (build-response #:headers `((content-type . (application/json))
                                        (expires . ,expiration-date)))
            (stubs:scm->json-string with-solid-oidc-supported))))

(define*-public (get-oidc-configuration host
                                        #:key
                                        (userinfo #f)
                                        (port #f)
                                        (http-get http-get))
  (when (and (string? host)
             (false-if-exception
              (string->uri host)))
    ;; host is something like "https://example.com"
    (set! host (string->uri host)))
  (when (uri? host)
    (set! host (uri-host host)))
  (let ((uri (build-uri 'https
                        #:userinfo userinfo
                        #:host host
                        #:port port
                        #:path "/.well-known/openid-configuration")))
    (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-oidc-configuration (stubs:json-string->scm response-body))))))))