SXML post-processing to remove absolute URLs

1 files changed, 23 insertions, 1 deletions

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)))