;; 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 client-manifest)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc web-i18n)
  #: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 (srfi srfi-26)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (sxml match)
  #:use-module (sxml simple)
  #:declarative? #t
  #:export
  (

   public-oidc-client

   &invalid-client-manifest
   make-invalid-client-manifest
   invalid-client-manifest?

   &unauthorized-redirect-uri
   make-unauthorized-redirect-uri
   unauthorized-redirect-uri?

   &inconsistent-client-manifest
   make-inconsistent-client-manifest
   inconsistent-client-manifest?

   &cannot-serve-public-manifest
   make-cannot-serve-public-manifest
   cannot-serve-public-manifest?

   &cannot-fetch-client-manifest
   make-cannot-fetch-client-manifest
   cannot-fetch-client-manifest?

   the-client-manifest
   client-manifest?
   make-client-manifest
   client-manifest-client-id
   client-manifest-check-redirect-uri

   serve-client-manifest
   get-client-manifest

   ))

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

(define-exception-type
  &invalid-client-manifest
  &external-error
  make-invalid-client-manifest
  invalid-client-manifest?)

(define-exception-type
  &unauthorized-redirect-uri
  &external-error
  make-unauthorized-redirect-uri
  unauthorized-redirect-uri?)

(define-exception-type
  &inconsistent-client-manifest
  &external-error
  make-inconsistent-client-manifest
  inconsistent-client-manifest?)

(define-exception-type
  &cannot-serve-public-manifest
  &external-error
  make-cannot-serve-public-manifest
  cannot-serve-public-manifest?)

(define-exception-type
  &cannot-fetch-client-manifest
  &external-error
  make-cannot-fetch-client-manifest
  cannot-fetch-client-manifest?)

(define (the-client-manifest x)
  (with-exception-handler
      (lambda (error)
        (let ((sysadmin-message
               (if (exception-with-message? error)
                   (format #f (G_ "this is not a client manifest: ~a")
                           (exception-message error))
                   (format #f (G_ "this is not a client manifest"))))
              (user-message
               (let ((new-paragraph
                      (sxml-match
                       (xml->sxml (W_ "<p>The client manifest could
not be queried. It can be because the client application is down, or
it is incomplete, or unusable for other reasons.</p>"))
                       ((*TOP* ,element)
                        element))))
                 (if (message-for-the-user? error)
                     (sxml-match
                      (user-message error)
                      ((div ,element ...)
                       `(div ,new-paragraph ,element ...))
                      (,element
                          `(div ,new-paragraph ,element)))
                     new-paragraph))))
          (raise-exception
           (make-exception
            (make-invalid-client-manifest)
            (make-exception-with-message sysadmin-message)
            (make-message-for-the-user user-message)
            error))))
    (lambda ()
      (let examine-fields ((fields x)
                           (client-id #f)
                           (redirect-uris #f)
                           (other-fields '()))
        (match fields
          (()
           (unless (and client-id redirect-uris)
             (fail (format #f (G_ "the client manifest is missing ~s")
                           (apply append
                                  `(,@(if client-id '() '("client_id"))
                                    ,@(if redirect-uris '() '("redirect_uris")))))))
           `((client_id . ,(uri->string client-id))
             (redirect_uris . ,(list->vector (map uri->string redirect-uris)))
             ,@(reverse other-fields)))
          ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) fields ...)
           (examine-fields fields (or client-id client-id-given)
                           redirect-uris other-fields))
          ((('client_id . invalid) _ ...)
           (fail (format #f (G_ "~s is an invalid \"client_id\" value, because it is not an URI")
                         invalid)))
          ((('redirect_uris . #((? string? (= string->uri (? uri? uri))) ...)) fields ...)
           (examine-fields fields client-id (or redirect-uris uri) other-fields))
          ((('redirect_uris . #(_ ...)) _ ...)
           (fail (format #f (G_ "at least one of the redirect URIs is not a proper URI"))))
          ((('redirect_uris . _) _ ...)
           (fail (format #f (G_ "the \"redirect_uris\" field should be a vector of URIs"))))
          ((other-field fields ...)
           (examine-fields fields client-id redirect-uris
                           `(,other-field ,@other-fields)))
          (else
           (fail (format #f (G_ "the client manifest should be a JSON object")))))))))

(define (client-manifest? x)
  (false-if-exception
   (the-client-manifest x)))

(define (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 (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)
  (match uris
    (()
     (let ((final-message
            (format #f (G_ "the client manifest does not allow ~s as a redirection uri")
                    (uri->string redir)))
           (final-user-message
            (sxml-match
             (xml->sxml (W_ "<p>The application wants to get your
authorization through <strong>~s</strong>, which is not
approved.</p>"))
             ((*TOP* ,element) element))))
       (raise-exception
        (make-exception
         (make-unauthorized-redirect-uri)
         (make-exception-with-message final-message)
         (make-message-for-the-user final-user-message)))))
    (((? (cute equal? <> redir) redir) _ ...)
     #t)
    ((_ uris ...)
     (check-redirect mf uris redir))))

(define (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)
                        (map string->uri (vector->list redirect-uris))
                        redir))))

(define (serve-client-manifest expiration-date mf)
  (when (eq? mf public-oidc-client)
    (let ((final-message
           (format #f (G_ "cannot serve the public manifest"))))
      (raise-exception
       (make-exception
        (make-cannot-serve-public-manifest)
        (make-exception-with-message final-message)))))
  (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* (get-client-manifest id
                              #:key
                              (http-get http-get))
  (unless (uri? id)
    (set! id (string->uri id)))
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (if (exception-with-message? error)
                   (format #f (G_ "cannot fetch the client manifest ~s: ~a")
                           (uri->string id)
                           (exception-message error))
                   (format #f (G_ "cannot fetch the client manifest ~s")
                           (uri->string id)))))
          (raise-exception
           (make-exception
            (make-cannot-fetch-client-manifest)
            (make-exception-with-message final-message)
            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? (client-manifest-client-id mf) id)
                (let ((final-message
                       (format #f (G_ "the client manifest is dereferenced from ~s, but it pretends to be ~s")
                               (uri->string id)
                               (uri->string (client-manifest-client-id mf)))))
                  (raise-exception
                   (make-exception
                    (make-inconsistent-client-manifest)
                    (make-exception-with-message final-message)))))
              mf))))))