;; 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 client-manifest)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc fetch)
  #: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)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf))

(define-public public-oidc-client
  'public-oidc-client)

(define-public (all-uris x)
  (or (null? x)
      (and (string->uri (car x))
           (all-uris (cdr x)))))

(define-public (the-client-manifest x)
  (if (eq? x public-oidc-client)
      public-oidc-client
      (let ((client-id (assq-ref x 'client_id))
            (redirect-uris (assq-ref x 'redirect_uris)))
        (unless (and client-id (string? client-id) (string->uri client-id))
          (raise-incorrect-client-id-field client-id))
        (unless (and redirect-uris
                     (vector? redirect-uris)
                     (all-uris (vector->list redirect-uris)))
          (raise-incorrect-redirect-uris-field redirect-uris))
        x)))

(define-public (client-manifest? obj)
  (false-if-exception
   (and (the-client-manifest obj) #t)))

(define-public (make-client-manifest client-id redirect-uris)
  (the-client-manifest
   `((client_id . ,(uri->string client-id))
     (redirect_uris . ,(list->vector
                        (map uri->string
                             redirect-uris))))))

(define-public (client-manifest-client-id mf)
  (if (eq? mf public-oidc-client)
      (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")
      (string->uri (assq-ref (the-client-manifest mf) 'client_id))))

(define (check-redirect mf uris redir)
  (if (null? uris)
      (raise-unauthorized-redirection-uri mf (string->uri redir))
      (or (string=? (car uris) redir)
          (check-redirect mf (cdr uris) redir))))

(define-public (client-manifest-check-redirect-uri mf redir)
  (unless (uri? redir)
    (set! redir (string->uri redir)))
  (if (eq? mf public-oidc-client)
      #t
      (let ((redirect-uris
             (assq-ref (the-client-manifest mf) 'redirect_uris)))
        (check-redirect (the-client-manifest mf)
                        (vector->list redirect-uris)
                        (uri->string redir)))))

(define-public (serve-client-manifest expiration-date mf)
  (when (eq? mf public-oidc-client)
    (raise-cannot-serve-public-manifest))
  (let ((json-object (stubs:scm->json-string
                      `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
                        ,@(the-client-manifest mf)))))
    (values (build-response #:headers `((content-type application/ld+json)
                                        (expires . ,expiration-date)))
            json-object)))

(define*-public (get-client-manifest id
                                     #:key
                                     (http-get http-get))
  (unless (uri? id)
    (set! id (string->uri id)))
  (with-exception-handler
      (lambda (error)
        (raise-cannot-fetch-client-manifest id error))
    (lambda ()
      (if (equal? id
                  (string->uri
                   "http://www.w3.org/ns/solid/terms#PublicOidcClient"))
          public-oidc-client
          (receive (response response-body)
              (http-get id)
            (when (bytevector? response-body)
              (set! response-body (utf8->string response-body)))
            (let ((mf (the-client-manifest (stubs:json-string->scm response-body))))
              (unless (equal? (uri->string (client-manifest-client-id mf))
                              (uri->string id))
                (raise-inconsistent-client-manifest-id
                 id
                 (client-manifest-client-id mf)))
              mf))))))