(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 (turtle-escape str)
  (define (folder c other)
    (if (or (eq? c #\\) (eq? c #\"))
        (cons* c #\\ other)
        (cons c other)))
  (list->string (reverse (string-fold folder '() str))))

(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 (the-client-manifest mf)))
        (id (uri->string (client-manifest-client-id (the-client-manifest mf)))))
    (let ((resource (string-append "
@prefix solid: <http://www.w3.org/ns/solid/terms#> .

<" id "> solid:oidcRegistration \"\"\"
" (turtle-escape json-object) "
\"\"\" .
")))
      (values (build-response #:headers `((content-type text/turtle)
                                          (expires . ,expiration-date)))
              resource))))

(define (find-registration id graph)
  (cond ((null? graph)
         (raise-no-client-manifest-registration (string->uri id)))
        ((and (string=? (rdf-triple-predicate (car graph))
                        "http://www.w3.org/ns/solid/terms#oidcRegistration")
              (string? (rdf-triple-subject (car graph)))
              (string=? (rdf-triple-subject (car graph)) id)
              (rdf-literal? (rdf-triple-object (car graph)))
              (string=? (rdf-literal-type (rdf-triple-object (car graph)))
                        "http://www.w3.org/2001/XMLSchema#string"))
         (let ((object (rdf-triple-object (car graph))))
           (let ((ret (stubs:json-string->scm (rdf-literal-lexical-form object))))
             (if (client-manifest? ret)
                 (begin
                   (unless (equal? (uri->string (client-manifest-client-id ret))
                                   id)
                     (raise-inconsistent-client-manifest-id (string->uri id)
                                                            (client-manifest-client-id ret)))
                   ret)
                 (find-registration id (cdr graph))))))
        (else (find-registration id (cdr graph)))))

(define*-public (get-client-manifest id
                                     #:key
                                     (http-get http-get))
  (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
          (let ((graph (fetch id #:http-get http-get)))
            (find-registration (uri->string id) graph))))))