;; 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 catalog)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (ice-9 match)
  #:use-module (web client)
  #:use-module (rnrs bytevectors)
  #:use-module (sxml simple)
  #:use-module (sxml match)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:export (resolve-uri))

(define useful-namespaces  
  '((ct . "urn:oasis:names:tc:entity:xmlns:xml:catalog")
    (xml . "http://www.w3.org/XML/1998/namespace")))

(define (run-catalog-entry do-examine-catalog base first-entry rest other-entries
                           uri
                           candidate match-length next-catalogs-rev)
  ;; do-examine-catalog is the recursive function to examine a new catalog.
  ;; base is the current base.
  ;; rest is a catalog containing the other entries.

  ;; This function is there because I can’t nest two sxml pattern
  ;; matchings.
  (sxml-match
   first-entry
   ((ct:group (@ (xml:base ,new-base)) ,group-entries ...)
    (let ((new-base (string->uri* base new-base)))
      (receive (candidate match-length next-catalogs-rev)
          (do-examine-catalog
           `(*TOP*
             (ct:catalog (@ (xml:base ,(uri->string new-base)))
                         ,@group-entries))
           candidate match-length next-catalogs-rev)
        (do-examine-catalog rest candidate match-length next-catalogs-rev))))
   ((ct:group ,group-entries ...)
    ;; The group does not have a specific base, we can merge the
    ;; entries with other-entries.
    (do-examine-catalog
     `(*TOP*
       (ct:catalog (@ (xml:base ,(uri->string base)))
                   ,@group-entries
                   ,@other-entries))
     candidate match-length next-catalogs-rev))
   ((ct:uri (@ (name ,exact-pattern)
               (uri ,replacement)
               (xml:base ,new-base)))
    ;; exact-pattern is not relative to xml:base
    (if (equal? (string->uri exact-pattern) uri)
        ;; Perfect replacement, stop here
        (values
         ;; but replacement is relative to xml:base
         (string->uri* base new-base replacement)
         (string-length (uri->string uri))
         '())
        (do-examine-catalog rest candidate match-length next-catalogs-rev)))
   ((ct:rewriteUri (@ (name ,pattern)
                      (uri ,replacement)
                      (xml:base ,new-base)))
    (when (and (string-prefix? pattern (uri->string uri))
               (> (string-length pattern) match-length))
      ;; The match is significant
      (set! candidate
            (string->uri* base
                          new-base
                          (string-append
                           replacement
                           (substring (uri->string uri)
                                      (string-length pattern)))))
      (set! match-length (string-length pattern)))
    ;; Maybe the match was perfect, in which case we must stop
    ;; there.
    (if (eqv? match-length (string-length (uri->string uri)))
        (values candidate match-length '())
        (do-examine-catalog rest candidate match-length next-catalogs-rev)))
   ((ct:uriSuffix (@ (uriSuffix ,suffix)
                     (uri ,replacement)
                     (base ,new-base)))
    (when (and (string-suffix? suffix (uri->string uri))
               (> (string-length suffix) match-length))
      (let* ((length-kept
              (- (string-length (uri->string uri))
                 (string-length suffix)))
             (part-kept (substring (uri->string uri) 0 length-kept)))
        (set! candidate
              (string->uri* base new-base (string-append part-kept suffix)))
        (set! match-length (string-length suffix))))
    (if (eqv? match-length (string-length (uri->string uri)))
        (values candidate match-length '())
        (do-examine-catalog rest candidate match-length next-catalogs-rev)))
   ((ct:delegateURI (@ (uriStartString ,pattern)
                       (catalog ,next-catalog)
                       (base ,new-base)))
    (if (string-prefix? pattern (uri->string uri))
        ;; Perfect match
        (values #f 0 (list (string->uri* base new-base next-catalog)))
        (do-examine-catalog rest candidate match-length next-catalogs-rev)))
   ((ct:nextCatalog (@ (catalog ,next-catalog)
                       (base ,new-base)))
    (do-examine-catalog rest candidate match-length
                        (cons (string->uri* base new-base next-catalog)
                              next-catalogs)))
   (,else
    (match first-entry
      ((node-name attributes/children ...)
       ;; The node is simply missing a base
       (do-examine-catalog
        `(*TOP*
          (ct:catalog (@ (xml:base ,(uri->string base)))
                      (,node-name (@ (xml:base ,(uri->string base))) ,@attributes/children)
                      ,@other-entries))
        candidate match-length next-catalogs-rev))
      (else
       (do-examine-catalog rest candidate match-length next-catalogs-rev))))))

(define (make-absolute base uri)
  (when (string? base)
    (set! base (string->uri base)))
  (let ((final-scheme (or (uri-scheme uri) (uri-scheme base)))
        (uri-with-final-authority
         (if (or (uri-scheme uri)
                 (uri-userinfo uri)
                 (uri-host uri)
                 (uri-port uri))
             ;; we should use that of uri
             uri
             ;; nothing specified, use base
             base))
        (final-path
         (if (or (uri-scheme uri)
                 (uri-userinfo uri)
                 (uri-host uri)
                 (uri-port uri)
                 (string-prefix? "/" (uri-path uri)))
             (uri-path uri)
             (let with-absolute-relative-path
                 ((defined '())
                  (components
                   (append (split-and-decode-uri-path (uri-path base))
                           (split-and-decode-uri-path (uri-path uri)))))
               (match components
                 (() (string-append "/" (encode-and-join-uri-path (reverse defined))))
                 (("" components ...) (with-absolute-relative-path defined components))
                 (("." components ...) (with-absolute-relative-path defined components))
                 ((".." components ...)
                  (match defined
                    (() (error "Invalid relative URI"))
                    ((dropped kept ...)
                     (with-absolute-relative-path kept components))))
                 ((head components ...)
                  (with-absolute-relative-path `(,head ,@defined) components))))))
        (uri-with-final-query
         (if (or (uri-scheme uri)
                 (uri-userinfo uri)
                 (uri-host uri)
                 (uri-port uri)
                 (not (equal? (uri-path uri) ""))
                 (uri-query uri))
             uri
             base)))
    (build-uri final-scheme
               #:userinfo (uri-userinfo uri-with-final-authority)
               #:host (uri-host uri-with-final-authority)
               #:port (uri-port uri-with-final-authority)
               #:path final-path
               #:query (uri-query uri-with-final-query)
               #:fragment (uri-fragment uri))))

(define (string->uri** base str)
  (make-absolute base (string->uri-reference str)))

(define (string->uri* base str . rest)
  (if (null? rest)
      (string->uri** base str)
      (apply string->uri* (string->uri** base str) rest)))

(define (resolve-uri-in-catalog uri catalog-uri catalog other-catalog-uris)
  (let do-examine-catalog ((catalog catalog)
                           (candidate uri)
                           (match-length 0)
                           (next-catalogs-rev (reverse other-catalog-uris)))
    (sxml-match
     catalog
     ((*TOP*
       (ct:catalog))
      ;; End of the catalog
      (values candidate
              match-length
              (if (eqv? match-length 0)
                  (reverse next-catalogs-rev)
                  '())))
     ((*TOP*
       (ct:catalog (@ (xml:base ,base))
                   ,first-entry
                   ,other-entries ...))
      (let* ((base (string->uri* catalog-uri base))
             (rest `(*TOP*
                     (ct:catalog (@ (xml:base ,(uri->string base)))
                                 ,@other-entries))))
        (run-catalog-entry do-examine-catalog base first-entry rest other-entries
                           uri
                           candidate match-length next-catalogs-rev)))
     ((*TOP*
       (ct:catalog ,entries ...))
      ;; No explicit xml:base
      (do-examine-catalog
       `(*TOP*
         (ct:catalog (@ (xml:base ,(uri->string catalog-uri)))
                     ,@entries))
       candidate
       match-length
       next-catalogs-rev)))))

(define* (get-catalog uri #:key (http-get http-get))
  (case (uri-scheme uri)
    ((http https)
     (receive (response response-body) (http-get uri)
       (when (bytevector? response-body)
         (set! response-body (utf8->string response-body)))
       (xml->sxml response-body #:namespaces useful-namespaces)))
    ((file)
     (call-with-input-file (uri-path uri)
       (lambda (port)
         (xml->sxml port #:namespaces useful-namespaces))))
    (else
     (error (format #f "Unsupported delegate catalog URI scheme: ~s\n" (uri-scheme uri))))))

(define* (resolve-uri uri #:key (http-get http-get))
  (when (string? uri)
    (set! uri (string->uri uri)))
  (let do-examine ((uris
                    (let ((var
                           (getenv "XML_CATALOG_FILES")))
                      (if var
                          (map string->uri
                               (string-split var #\space))
                          '()))))
    (match uris
      (() uri)
      ((catalog-uri uris ...)
       (let ((catalog (get-catalog catalog-uri
                                   #:http-get http-get)))
         (receive (candidate match-length next-uris)
             (resolve-uri-in-catalog uri catalog-uri catalog uris)
           (if (null? next-uris)
               candidate
               (do-examine next-uris))))))))