diff options
Diffstat (limited to 'src/scm/webid-oidc/catalog.scm')
| -rw-r--r-- | src/scm/webid-oidc/catalog.scm | 264 |
1 files changed, 264 insertions, 0 deletions
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)))))))) |