The server supports XML catalogs.

This will be used to set up an integration test suite with HTTPS,
without needing to provide certificates, because the test harness will
have an XML catalog mapping HTTPS targets to local HTTP mockups.

3 files changed, 292 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 0046ca4..acd9ec9 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -45,7 +45,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/example-app.scm \
   %reldir%/rdf-index.scm \
   %reldir%/http-link.scm \
-  %reldir%/offloading.scm
+  %reldir%/offloading.scm \
+  %reldir%/catalog.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -78,7 +79,8 @@ webidoidcgo_DATA += \
   %reldir%/example-app.go \
   %reldir%/rdf-index.go \
   %reldir%/http-link.go \
-  %reldir%/offloading.go
+  %reldir%/offloading.go \
+  %reldir%/catalog.go
 
 EXTRA_DIST += %reldir%/ChangeLog
 
diff --git a/src/scm/webid-oidc/catalog.scm b/src/scm/webid-oidc/catalog.scm
new file mode 100644
index 0000000..11e0877
--- /dev/null
+++ b/src/scm/webid-oidc/catalog.scm
@@ -0,0 +1,264 @@
+;; 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))))))))
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 79f13cb..6b8ad29 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -24,6 +24,7 @@
   #:use-module (webid-oidc server create)
   #:use-module (webid-oidc jti)
   #:use-module (webid-oidc offloading)
+  #:use-module (webid-oidc catalog)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (ice-9 optargs)
@@ -55,8 +56,20 @@
   (define date (date->string (time-utc->date (current-time))))
   (define uri-string (if (uri? uri) (uri->string uri) uri))
   (with-mutex logging-mutex
+    (when (getenv "XML_CATALOG_FILES")
+      (format (current-error-port) "~a: Warning: XML_CATALOG_FILES is set to ~s.\n"
+              date
+              (getenv "XML_CATALOG_FILES")))
     (format (current-error-port) "~a: GET ~a ~s...\n"
             date uri-string headers))
+  (set! uri (resolve-uri uri
+                         #:http-get
+                         (lambda* (uri . args)
+                           (with-mutex logging-mutex
+                             (format (current-error-port) "~a: Warning: loading XML catalog from the web, ~s.\n"
+                                     date
+                                     (uri->string uri)))
+                           (apply http-get uri args))))
   (receive (response response-body)
       (in-another-thread
        (http-get uri #:headers headers))
@@ -399,6 +412,17 @@ Options for the client service:"))
         (format #t (G_ "
 Environment variables:"))
         (format #t (G_ "
+  XML_CATALOG_FILES: the server will fetch resources on the web. By
+      setting this environment variable to a space-separated list of
+      catalog URIs, the server will redirect these requests to another
+      server. Currently, it is not possible to load files from the
+      file system, because there is no way to specify the
+      content-type."))
+        (when (getenv "XML_CATALOG_FILES")
+          (format #t (G_ "the-environment-variable|
+      It is currently set to ~s.")
+                  (getenv "XML_CATALOG_FILES")))
+        (format #t (G_ "
   LANG: set the locale of the user interface (for the server commands,
       the user is the system administrator)."))
         (when (getenv "LANG")