;; 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 server endpoint)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc serializable)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #: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)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (

   &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?

   <client-manifest>
   client-id
   redirect-uris

   ->json-data

   check-redirect-uri
   serve

   ))

(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 public-client-uri
  (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient"))

(define-class <client-manifest> ()
  (client-id #:init-keyword #:client-id #:accessor client-id #:->jwks uri->string)
  (redirect-uris #:init-keyword #:redirect-uris #:accessor redirect-uris #:->jwks uri->string)
  #:metaclass <plugin-class>
  #:module-name '(webid-oidc client-manifest))

(define-method (initialize (client <client-manifest>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((client-id #f)
    (redirect-uris #f))
   (let do-initialize ((client-id client-id)
                       (redirect-uris redirect-uris))
     (when (list? redirect-uris)
       (set! redirect-uris
             (map
              (match-lambda
                ((or (? string? (= string->uri (? uri? value)))
                     value)
                 value))
              redirect-uris)))
     (cond
      ((string? client-id)
       (do-initialize (string->uri client-id) redirect-uris))
      ((equal? client-id public-client-uri)
       (slot-set! client 'client-id client-id)
       (slot-set! client 'redirect-uris '()))
      ((not redirect-uris)
       (receive (response response-body) ((p:anonymous-http-request) client-id)
         (with-exception-handler
             (lambda (error)
               (raise-exception
                (make-exception
                 (make-cannot-fetch-client-manifest)
                 (make-exception-with-message
                  (if (exception-with-message? error)
                      (format #f (G_ "cannot fetch a client manifest: ~a")
                              (exception-message error))
                      (format #f (G_ "cannot fetch a client manifest"))))
                 error)))
           (lambda ()
             (when (bytevector? response-body)
               (set! response-body (utf8->string response-body)))
             (unless (eqv? (response-code response) 200)
               (raise-exception
                (make-exception
                 (make-exception-with-message
                  (format #f (G_ "the server responded with code ~a")
                          (response-code response)))
                 (make-user-message
                  (call-with-input-string
                      (format #f (W_ "<p>The server hosting your application responded with code ~a.<p>")
                              (response-code response))
                    xml->sxml)))))
             (let ((json-data (stubs:json-string->scm response-body)))
               (let ((new-client-id (assq-ref json-data 'client_id))
                     (redirect-uris (assq-ref json-data 'redirect_uris)))
                 (unless (string? new-client-id)
                   (raise-exception
                    (make-exception
                     (make-exception-with-message
                      (G_ "the client manifest does not have a client_id field"))
                     (make-user-message
                      (call-with-input-string
                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>"))
                        xml->sxml)))))
                 (set! redirect-uris
                       (let fix-redirect-uris ((redirect-uris redirect-uris))
                         (match redirect-uris
                           ((? vector? (= vector->list redirect-uris))
                            redirect-uris)
                           ((? list? redirect-uris)
                            (map fix-redirect-uris redirect-uris))
                           ((? string? (= string->uri (? uri? uri)))
                            uri)
                           (anything anything))))
                 (set! new-client-id
                       (match new-client-id
                         ((? string? (= string->uri (? uri? uri)))
                          uri)
                         (anything anything)))
                 (unless redirect-uris
                   (raise-exception
                    (make-exception
                     (make-exception-with-message
                      (G_ "the client manifest does not have a redirect_uris field"))
                     (make-user-message
                      (call-with-input-string
                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the redirect_uris field.<p>"))
                        xml->sxml)))))
                 (unless new-client-id
                   (raise-exception
                    (make-exception
                     (make-exception-with-message
                      (G_ "the client manifest does not have a client_id field"))
                     (make-user-message
                      (call-with-input-string
                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>"))
                        xml->sxml)))))
                 (unless (equal? client-id new-client-id)
                   (raise-exception
                    (make-exception
                     (make-inconsistent-client-manifest)
                     (make-exception-with-message
                      (format #f (G_ "the client manifest under ~s has a client_id of ~s")
                              (uri->string client-id)
                              (uri->string new-client-id)))
                     (make-user-message
                      (call-with-input-string
                          (format #f (W_ "<p>The application you want to use does not control the domain name it appears to represent.</p>"))
                        xml->sxml)))))
                 (do-initialize new-client-id redirect-uris)))))))
      (else
       (unless (uri? client-id)
         (scm-error 'wrong-type-arg "make"
                    (G_ "#:client-id should be an URI")
                    '()
                    (list client-id)))
       (unless (let check-redirect-uris ((redirect-uris redirect-uris))
                 (match redirect-uris
                   (() #t)
                   (((? uri?) redirect-uris ...)
                    (check-redirect-uris redirect-uris))))
         (scm-error 'wrong-type-arg "make"
                    (G_ "#:redirect-uris should be a list of URIs")
                    '()
                    (list redirect-uri)))
       (slot-set! client 'client-id client-id)
       (slot-set! client 'redirect-uris redirect-uris))))))

(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
            (call-with-input-string
                (format #f (W_ "<p>The application wants to get your
authorization through <strong>~a</strong>, which is not
approved.</p>")
                        (call-with-output-string
                          (cute sxml->xml `(*TOP* ,(uri->string redir)) <>)))
              xml->sxml)))
       (raise-exception
        (make-exception
         (make-unauthorized-redirect-uri)
         (make-exception-with-message final-message)
         (make-user-message final-user-message)))))
    (((? (cute equal? <> redir) redir) _ ...)
     #t)
    ((_ uris ...)
     (check-redirect mf uris redir))))

(define-method (check-redirect-uri (mf <client-manifest>) redir)
  (unless (uri? redir)
    (set! redir (string->uri redir)))
  (or (equal? (client-id mf) public-client-uri)
      (check-redirect mf (redirect-uris mf) redir)))

(define-method (->json-data (mf <client-manifest>))
  (let ((other
         (catch 'goops-error
           (lambda ()
             (next-method))
           (lambda _
             '()))))
    `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
      (client_id . ,(uri->string (client-id mf)))
      (redirect_uris . ,(list->vector (map uri->string (redirect-uris mf))))
      ,@other)))

(define-method (serve (mf <client-manifest>) expiration-date)
  (when (equal? (client-id mf) public-client-uri)
    (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
                      (->json-data mf))))
    (let ((etag (stubs:hash 'SHA-256 json-object)))
      (values (build-response #:headers `((content-type application/ld+json)
                                          (etag . (,etag . #t))
                                          ,@(if expiration-date
                                                `((expires . ,expiration-date))
                                                `((cache-control public must-revalidate)))))
              json-object))))