From ee058251b6be2c736b14e79217ff0c100708998c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 14 Aug 2020 00:43:24 +0200
Subject: Fix /static/ links in generated html + extra.

---
 module/output/html.scm          | 25 +++++++++++++++----------
 module/sxml/transformations.scm |  2 +-
 2 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/module/output/html.scm b/module/output/html.scm
index f3ed6dc8..ca4bf83d 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -21,7 +21,11 @@
   #:use-module ((vcomponent instance methods)
                 :select (get-calendars get-event-set))
 
+
+  #:use-module ((ice-9 regex) :select (string-match regexp-substitute))
+
   #:use-module ((sxml simple) :select (sxml->xml))
+  #:use-module ((sxml transformations) :select (href-transformer))
 
   #:autoload (vcomponent instance) (global-event-object)
   )
@@ -40,7 +44,7 @@
 
 
 (define (get-filename start-date)
-  (format #f "~a/html/~a.html"
+  (format #f "~a/html/~a.xml"
           (dirname (or (@ (global) basedir) "."))
           (date->string start-date "~1")))
 
@@ -58,7 +62,14 @@
    (lambda (start-date)
      (define fname (get-filename start-date))
      (format (current-error-port) "Writing to [~a]~%" fname)
-     (with-output-to-file fname (lambda () (sxml->xml (proc calendars events))) ))
+     (with-output-to-file fname
+       (lambda () (sxml->xml
+              (href-transformer
+               (proc calendars events)
+               (lambda (str)
+                 (aif (string-match "^/static" str)
+                      (regexp-substitute #f it 'pre "static" 'post)
+                      str)))))))
    (stream-take count (date-stream chunk-length start-date))
    ))
 
@@ -77,20 +88,13 @@
                            prev-start: (lambda (d) (date- d chunk-length))
                            ))))
 
-
-
 (define-public (html-table-main count start-date)
 
   (common count start-date (date month: 1)
-          (let* ((before current after
-                         (month-days start-date)))
-
-            ;; TODO this produces incorrect next and prev links
-            ;; TODO It actually produces almost all date links wrong
+          (let* ((before current after (month-days start-date)))
             (lambda (calendars events)
               (html-generate calendars: calendars
                              events: events
-                             ;; Appends for case where before or after is empty
                              start-date: (car current)
                              end-date: (date- (if (null? after)
                                                   (last current)
@@ -99,6 +103,7 @@
                              render-calendar: render-calendar-table
                              next-start: month+
                              prev-start: month-
+                             ;; Appends for case where before or after is empty
                              pre-start: (car (append before current))
                              post-end: (last (append current after))
                              )))))
diff --git a/module/sxml/transformations.scm b/module/sxml/transformations.scm
index e57c0433..037dc00f 100644
--- a/module/sxml/transformations.scm
+++ b/module/sxml/transformations.scm
@@ -28,7 +28,7 @@
   (attribute-transformer
    tree
    `((href . ,(lambda (_ . content)
-                `(href ,@(transformer (string-concatenate content)))
+                `(href ,@(transformer (string-concatenate (map ->str content))))
                 )))))
 
 (define-public (href-prefixer tree prefix)
-- 
cgit v1.2.3