diff options
| -rw-r--r-- | haunt/jakob/reader/html-prime.scm | 4 | ||||
| -rw-r--r-- | haunt/jakob/utils/sxml.scm | 24 | ||||
| -rw-r--r-- | haunt/pages/about-complete.sxml | 3 |
3 files changed, 28 insertions, 3 deletions
diff --git a/haunt/jakob/reader/html-prime.scm b/haunt/jakob/reader/html-prime.scm index 7503440..417249e 100644 --- a/haunt/jakob/reader/html-prime.scm +++ b/haunt/jakob/reader/html-prime.scm @@ -25,6 +25,7 @@ #:use-module (haunt post) #:use-module (haunt reader) #:use-module (ice-9 match) + #:use-module (jakob utils sxml) #:use-module (srfi srfi-26) #:use-module (sxml simple) #:export (html-reader-prime)) @@ -37,7 +38,8 @@ (match (xml->sxml port) (('*TOP* sxml) (loop (cons sxml ret))))) (lambda (key . parameters) - (reverse ret)))))) + (rewrite-absolute-urls-as-relative + (reverse ret))))))) (define html-reader-prime (make-reader (make-file-extension-matcher "html") diff --git a/haunt/jakob/utils/sxml.scm b/haunt/jakob/utils/sxml.scm index 1f4bb78..0fc34d2 100644 --- a/haunt/jakob/utils/sxml.scm +++ b/haunt/jakob/utils/sxml.scm @@ -22,7 +22,8 @@ stylesheet script - sanitize-subtree)) + sanitize-subtree + rewrite-absolute-urls-as-relative)) ;;; @@ -67,3 +68,24 @@ sanitize the resultant subtree." ;; Install the reader extension when imported. (read-hash-extend #\< sxml-reader) + +(define (rewrite-absolute-urls-as-relative tree) + (match tree + (('a attrs body ...) + (if (assoc 'href (cdr attrs)) + (let* ((url (car (assoc-ref (cdr attrs) 'href))) + (url (if (string-prefix? "https://jakob.space" url) + (string-drop url (string-length "https://jakob.space")) + url)) + (url (if (string-prefix? "http://jakob.space" url) + (string-drop url (string-length "http://jakob.space")) + url)) + (attrs `(@ (href ,url) ,@(filter (match-lambda + (('href _) #f) + (_ #t)) + (cdr attrs))))) + `(a ,attrs ,@body)) + tree)) + ((xs ...) + (map rewrite-absolute-urls-as-relative xs)) + (elem elem))) diff --git a/haunt/pages/about-complete.sxml b/haunt/pages/about-complete.sxml index 8ac5042..fa0fb27 100644 --- a/haunt/pages/about-complete.sxml +++ b/haunt/pages/about-complete.sxml @@ -27,4 +27,5 @@ #:content (cadr (call-with-input-file "pages/about-complete.html" (lambda (port) (read-line port) - (xml->sxml port))))) + (rewrite-absolute-urls-as-relative + (xml->sxml port)))))) |