Merge html-validator.

Adds an HTML validator which checks the soundness of our generated
document, both before and after javascript is ran (thanks to selenium).

This merge also fixes the initial problems, meaning that the HTML should
validate as of this commit.

13 files changed, 232 insertions, 96 deletions

diff --git a/doc/ref/javascript/components/tab_group_element.texi b/doc/ref/javascript/components/tab_group_element.texi
index 67f3a359..7e0b190a 100644
--- a/doc/ref/javascript/components/tab_group_element.texi
+++ b/doc/ref/javascript/components/tab_group_element.texi
@@ -14,12 +14,12 @@ it, and a tab-element, which contains the actual content. These two
 should refer to each other as follows:
 
 @example
-+---------------+     +----------------+
-|   TabLabel    |     |       Tab      |
-+---------------+     +----------------+
-|            id |<----| aria-labeledby |
-| aria-controls |---->|             id |
-+---------------+     +----------------+
++---------------+     +-----------------+
+|   TabLabel    |     |       Tab       |
++---------------+     +-----------------+
+|            id |<----| aria-labelledby |
+| aria-controls |---->|              id |
++---------------+     +-----------------+
 @end example
 
 Further information about tabs in HTML can be found here:
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
index 6ff59502..a36dbef9 100644
--- a/module/calp/html/components.scm
+++ b/module/calp/html/components.scm
@@ -110,26 +110,6 @@
                 ,@inner-body)]))
 
 
-(define-public (with-label lbl . forms)
-
-  (define id (gensym "label"))
-
-  (cons `(label (@ (for ,id)) ,lbl)
-   (let recurse ((forms forms))
-     (map (lambda (form)
-            (cond [(not (list? form)) form]
-                  [(null? form) '()]
-                  [(eq? 'input (car form))
-                   ((set-attribute `((id ,id))) form)]
-                  [(list? (car form))
-                   (cons (recurse (car form))
-                         (recurse (cdr form)))]
-                  [else
-                   (cons (car form)
-                         (recurse (cdr form)))]))
-          forms))))
-
-
 (define-public (include-css path . extra-attributes)
   `(link (@ (type "text/css")
             (rel "stylesheet")
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index 27a1f994..069b9a28 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -13,7 +13,6 @@
   :use-module ((web uri-query) :select (encode-query-parameters))
   :use-module ((calp html util) :select (html-id calculate-fg-color))
   :use-module ((calp html config) :select (edit-mode debug))
-  :use-module ((calp html components) :select (with-label))
   :use-module ((crypto) :select (sha256 checksum->string))
   :use-module ((xdg basedir) :prefix xdg-)
   :use-module ((vcomponent recurrence) :select (repeating?))
@@ -29,6 +28,12 @@
   )
 
 
+(define (xml-entities s)
+  (lambda ()
+    (for-each display
+     (map (lambda (c) (format #f "&#x~x;" (char->integer c)))
+          (string->list s)))))
+
 (define-public (format-summary ev str)
   ((summary-filter) ev str))
 
@@ -400,64 +405,55 @@
                                             '((selected))))
                                      ,name))
                           calendars)))
-               (h3 (input (@ (type "text")
-                             (placeholder ,(_ "Summary"))
-                             (name "summary") (required)
-                             (data-property "summary")
+               (input (@ (type "text")
+                         (placeholder ,(_ "Summary"))
+                         (name "summary") (required)
+                         (data-property "summary")
                                         ; (value ,(prop ev 'SUMMARY))
-                             )))
+                         ))
 
                (div (@ (class "timeinput"))
 
-                    ,@(with-label
-                       (_ "Start time")
-                       '(date-time-input (@ (name "dtstart")
-                                            (data-property "dtstart")
-                                            )))
+                    (date-time-input (@ (name "dtstart")
+                                         (data-property "dtstart")
+                                         ))
 
-                    ,@(with-label
-                       (_ "End time")
-                       '(date-time-input (@ (name "dtend")
-                                            (data-property "dtend"))))
+                    (date-time-input (@ (name "dtend")
+                                         (data-property "dtend")))
 
                     (div (@ (class "checkboxes"))
-                         ,@(with-label
-                            (_ "Whole day?")
-                            `(input (@ (type "checkbox")
-                                       (name "wholeday")
-                                       )))
-                         ,@(with-label
-                            (_ "Recurring?")
-                            `(input (@ (type "checkbox")
-                                       (name "has_repeats")
-                                       ))))
+                         (input (@ (type "checkbox")
+                                   (name "wholeday")
+                                   (data-label ,(_ "Whole day?"))
+                                   ))
+                         (input (@ (type "checkbox")
+                                   (name "has_repeats")
+                                   (data-label ,(_ "Recurring?"))
+                                   )))
 
                     )
 
-               ,@(with-label
-                  (_ "Location")
-                  `(input (@ (placeholder ,(_ "Location"))
-                             (name "location")
-                             (type "text")
-                             (data-property "location")
+               (input (@ (placeholder ,(_ "Location"))
+                         (data-label ,(_ "Location"))
+                         (name "location")
+                         (type "text")
+                         (data-property "location")
                                         ; (value ,(or (prop ev 'LOCATION) ""))
-                             )))
+                         ))
 
-               ,@(with-label
-                  (_ "Description")
-                  `(textarea (@ (placeholder ,(_ "Description"))
-                                (data-property "description")
-                                (name "description"))
+               (textarea (@ (placeholder ,(_ "Description"))
+                            (data-label ,(_ "Description"))
+                            (data-property "description")
+                            (name "description"))
                                         ; ,(prop ev 'DESCRIPTION)
-                             ))
+                         )
 
-               ,@(with-label
-                  (_ "Categories")
-                  `(input-list
-                    (@ (name "categories")
-                       (data-property "categories"))
-                    (input (@ (type "text")
-                              (placeholder ,(_ "Category"))))))
+               (input-list
+                (@ (name "categories")
+                   (data-property "categories")
+                   (data-label ,(_ "Categories")))
+                (input (@ (type "text")
+                          (placeholder ,(_ "Category")))))
 
                ;; TODO This should be a "list" where any field can be edited
                ;; directly. Major thing holding us back currently is that
@@ -606,20 +602,20 @@
                          (title ,(_ "Fullscreen"))
                          ;; (aria-label "")
                          )
-                      "🗖")
+                      ,(xml-entities "🗖"))
               (button (@ (class "remove-button")
                          ;; Remove/Trash the event this popup represent
                          ;; Think garbage can
                          (title ,(_ "Remove")))
-                      "🗑"))
+                      ,(xml-entities "🗑")))
 
          (tab-group (@ (class "window-body"))
                     (vevent-description
-                     (@ (data-label "📅") (data-title ,(_ "Overview"))
+                     (@ (data-label ,(xml-entities "📅")) (data-title ,(_ "Overview"))
                         (class "vevent")))
 
                     (vevent-edit
-                     (@ (data-label "🖊")
+                     (@ (data-label ,(xml-entities "🖊"))
                         (data-title ,(_ "Edit"))
                         ;; Used by JavaScript to target this tab
                         (data-originaltitle "Edit")))
@@ -628,10 +624,10 @@
                     ;;  (@ (data-label "↺") (data-title "Upprepningar")))
 
                     (vevent-changelog
-                     (@ (data-label "📒")
+                     (@ (data-label ,(xml-entities "📒"))
                         (data-title ,(_ "Changelog"))))
 
                     ,@(when (debug)
                         `((vevent-dl
-                           (@ (data-label "🐸")
+                           (@ (data-label ,(xml-entities "🐸"))
                               (data-title ,(_ "Debug"))))))))))
diff --git a/static/components/tab-group-element.ts b/static/components/tab-group-element.ts
index 8a65964d..e90997e9 100644
--- a/static/components/tab-group-element.ts
+++ b/static/components/tab-group-element.ts
@@ -29,7 +29,7 @@ class TabGroupElement extends ComponentVEvent {
     constructor(uid?: string) {
         super(uid);
 
-        this.menu = makeElement('menu', {}, {
+        this.menu = makeElement('div', {}, {
             role: 'tablist',
             'aria-label': 'Simple Tabs',
         })
@@ -105,15 +105,15 @@ class TabGroupElement extends ComponentVEvent {
             title: title,
             'aria-selected': false,
             'aria-controls': tab_id,
-            ... extra_attributes,
+            ...extra_attributes,
         })
 
-        let tabContainer = makeElement('article', {}, {
+        let tabContainer = makeElement('div', {}, {
             id: tab_id,
             role: 'tabpanel',
             tabindex: 0,
             hidden: 'hidden',
-            'aria-labeledby': label_id,
+            'aria-labelledby': label_id,
         })
 
         tabContainer.replaceChildren(child);
@@ -129,7 +129,7 @@ class TabGroupElement extends ComponentVEvent {
     }
 
     removeTab(tab: HTMLElement) {
-        let id = tab.getAttribute('aria-labeledby')!
+        let id = tab.getAttribute('aria-labelledby')!
         let label = document.getElementById(id)
         if (label) {
             if (label.ariaSelected === 'true') {
@@ -156,7 +156,7 @@ class TabGroupElement extends ComponentVEvent {
 
         /* hide all tab panels */
         for (let tabcontent of this.querySelectorAll('[role="tabpanel"]')) {
-            tabcontent.setAttribute('hidden', 'true');
+            tabcontent.setAttribute('hidden', 'hidden');
         }
         /* unselect all (selected) tab handles */
         for (let item of this.querySelectorAll('[aria-selected="true"]')) {
@@ -174,7 +174,7 @@ class TabGroupElement extends ComponentVEvent {
     /* returns our rrule tab if we have one */
     has_rrule_tab(): Element | false {
         for (let child of this.children) {
-            if ((child.firstChild! as HTMLElement).tagName.toLowerCase() === 'vevent-edit-rrule') {
+            if (child.firstChild! instanceof EditRRule) {
                 return child;
             }
         }
diff --git a/static/components/vevent-edit.ts b/static/components/vevent-edit.ts
index ee368296..bf72678c 100644
--- a/static/components/vevent-edit.ts
+++ b/static/components/vevent-edit.ts
@@ -7,7 +7,7 @@ import { DateTimeInput } from './date-time-input'
 import { vcal_objects } from '../globals'
 import { VEvent, RecurrenceRule } from '../vevent'
 import { create_event } from '../server_connect'
-import { to_boolean } from '../lib'
+import { to_boolean, gensym } from '../lib'
 
 /* <vevent-edit />
    Edit form for a given VEvent. Used as the edit tab of popups.
@@ -24,6 +24,14 @@ class ComponentEdit extends ComponentVEvent {
         let frag = this.template.content.cloneNode(true) as DocumentFragment
         let body = frag.firstElementChild!
         this.replaceChildren(body);
+
+        for (let el of this.querySelectorAll('[data-label]')) {
+            let label = document.createElement('label');
+            let id = el.id || gensym('input');
+            el.id = id;
+            label.htmlFor = id;
+            label.textContent = (el as HTMLElement).dataset.label!;
+        }
     }
 
     connectedCallback() {
diff --git a/static/components/vevent.ts b/static/components/vevent.ts
index 2193eabc..5852a2ff 100644
--- a/static/components/vevent.ts
+++ b/static/components/vevent.ts
@@ -19,7 +19,6 @@ abstract class ComponentVEvent extends HTMLElement {
 
         let real_uid;
 
-        // console.log(this.tagName);
         if (uid) {
             // console.log('Got UID directly');
             real_uid = uid;
diff --git a/static/formatters.ts b/static/formatters.ts
index 828a0e8b..70f63504 100644
--- a/static/formatters.ts
+++ b/static/formatters.ts
@@ -6,11 +6,11 @@ import { makeElement } from './lib'
 
 declare global {
     interface Window {
-        formatters : Map<string, (e : HTMLElement, s : any) => void>;
+        formatters: Map<string, (e: HTMLElement, s: any) => void>;
     }
 }
 
-let formatters : Map<string, (e : HTMLElement, s : any) => void>;
+let formatters: Map<string, (e: HTMLElement, s: any) => void>;
 formatters = window.formatters = new Map();
 
 
@@ -18,13 +18,34 @@ formatters.set('categories', (el, d) => {
     for (let item of d) {
         let q = encodeURIComponent(
             `(member "${item}" (or (prop event (quote CATEGORIES)) (quote ())))`)
-            el.appendChild(makeElement('a', {
-                textContent: item,
-                href: `/search/?q=${q}`,
-            }))
+        el.appendChild(makeElement('a', {
+            textContent: item,
+            href: `/search/?q=${q}`,
+        }))
     }
 })
 
+function format_time_tag(el: HTMLElement, d: any): void {
+    if (el instanceof HTMLTimeElement) {
+        if (d instanceof Date) {
+            let fmt = '';
+            if (!d.utc) {
+                fmt += '~L';
+            }
+            fmt += '~Y-~m-~d'
+            if (!d.dateonly) {
+                fmt += 'T~H:~M:~S'
+            }
+            el.dateTime = d.format(fmt);
+        }
+    }
+
+    formatters.get('default')!(el, d);
+}
+
+formatters.set('dtstart', format_time_tag)
+formatters.set('dtend', format_time_tag)
+
 formatters.set('default', (el, d) => {
     let fmt;
     if ((fmt = el.dataset.fmt)) {
diff --git a/static/globals.ts b/static/globals.ts
index ddc9113e..d90a3681 100644
--- a/static/globals.ts
+++ b/static/globals.ts
@@ -51,8 +51,8 @@ function find_block(uid: uid): ComponentBlock | null {
         return null;
     }
     for (let el of obj.registered) {
-        if (el.tagName.toLowerCase() === 'vevent-block') {
-            return el as ComponentBlock;
+        if (el instanceof ComponentBlock) {
+            return el;
         }
     }
     // throw 'Popup not fonud';
diff --git a/static/server_connect.ts b/static/server_connect.ts
index 61eb4f30..d1a544eb 100644
--- a/static/server_connect.ts
+++ b/static/server_connect.ts
@@ -4,6 +4,7 @@ import { jcal_to_xcal } from './jcal'
 import { VEvent } from './vevent'
 import { uid } from './types'
 import { vcal_objects } from './globals'
+import { PopupElement } from './components/popup-element'
 
 async function remove_event(uid: uid) {
     let element = vcal_objects.get(uid);
@@ -124,7 +125,7 @@ async function create_event(event: VEvent) {
 
     for (let r of event.registered) {
         r.classList.remove('generated');
-        if (r.tagName.toLowerCase() === 'popup-element') {
+        if (r instanceof PopupElement) {
             console.log(r);
             r.removeAttribute('visible');
         }
diff --git a/tests/test/html/component.scm b/tests/test/html/component.scm
index 050810be..7d17be7f 100644
--- a/tests/test/html/component.scm
+++ b/tests/test/html/component.scm
@@ -23,7 +23,6 @@
   (btn class: '("test") "body"))
 
 ;; tabset
-;; with-label
 
 (test-equal '(link (@ (type "text/css") (rel "stylesheet") (href "style.css")))
   (include-css "style.css"))
diff --git a/tests/validate-html/.gitignore b/tests/validate-html/.gitignore
new file mode 100644
index 00000000..1ac40fc2
--- /dev/null
+++ b/tests/validate-html/.gitignore
@@ -0,0 +1,2 @@
+*.xhtml
+geckodriver.log
diff --git a/tests/validate-html/fetch_data.py b/tests/validate-html/fetch_data.py
new file mode 100755
index 00000000..14ecca75
--- /dev/null
+++ b/tests/validate-html/fetch_data.py
@@ -0,0 +1,46 @@
+#!/usr/bin/env python
+
+import subprocess
+import urllib.request
+
+from selenium import webdriver
+from selenium.webdriver.firefox.options import Options
+
+def fetch_rendered(url, port):
+    options = Options()
+    options.add_argument('--headless')
+    driver = webdriver.Firefox(options=options)
+
+    driver.get(url)
+    page_source = driver.page_source
+
+    # TODO check encoding from driver
+    page_encoded = page_source.encode('utf-8')
+
+    cmd = subprocess.run(['xmllint', '--format', '-'],
+            input=page_encoded,
+            capture_output=True)
+
+    if cmd.returncode == 0:
+        port.write(cmd.stdout)
+    else:
+        port.write(page_encoded)
+
+def fetch_raw(url, port):
+    response = urllib.request.urlopen(url)
+    data = response.read()
+    port.write(data)
+    
+url = 'http://localhost:8080/week/2022-03-31.html'
+
+with open('raw.xhtml', 'wb') as f:
+    fetch_raw(url, f)
+
+# with open('raw.html', 'wb') as f:
+#     fetch_raw(f'{url}?html', f)
+
+with open('selenium.xhtml', 'wb') as f:
+    fetch_rendered(url, f)
+
+# with open('selenium.html', 'wb') as f:
+#     fetch_rendered(f'{url}?html', f)
diff --git a/tests/validate-html/run-validator.scm b/tests/validate-html/run-validator.scm
new file mode 100755
index 00000000..7e3c9f76
--- /dev/null
+++ b/tests/validate-html/run-validator.scm
@@ -0,0 +1,84 @@
+#!/usr/bin/bash
+# -*- mode: scheme; geiser-scheme-implementation: guile -*-
+here=$(dirname $(realpath $0))
+
+. "$(dirname "$(dirname "$here")")/env"
+
+exec $GUILE -e main -s "$0" -- "$@"
+!#
+
+(use-modules (sxml simple)
+             ((sxml xpath) :select (sxpath))
+             (sxml match)
+             (rnrs lists)
+             (ice-9 regex)
+             (ice-9 popen)
+             (ice-9 format)
+             ((hnh util) :select (group-by ->)))
+
+(define (error-string error)
+ (cond (((sxpath '(// nu:message)) error)
+        (negate null?) => (compose sxml->string car))
+       (else "")))
+
+(define (ignore-rule error)
+  (string-match "Element (calendar|icalendar) not allowed as child"
+                (error-string error)))
+
+(define (group-by-file entries)
+  (group-by (sxpath '(// @ url))
+            entries))
+
+(define (display-entry entry)
+  (sxml-match
+   entry
+   [(nu:error (@ (last-line ,last-line)
+                 (first-column ,first-column)
+                 (last-column ,last-column))
+              (nu:message ,msg ...)
+              (nu:extract ,extract ...))
+    (format #t "  - ERROR - ~a:~a-~a - ~a - ~a~%"
+            last-line first-column last-column
+            (sxml->string `(nu:message ,@msg))
+            (sxml->string `(nu:extract ,@extract)))]
+
+   [(nu:info (@ (last-line ,last-line)
+                (first-column ,first-column)
+                (last-column ,last-column)
+                (type ,type))
+             (nu:message ,msg ...)
+             (nu:extract ,extract ...))
+    (format #t "  - ~5a - ~a:~a-~a - ~a - ~a~%"
+            type last-line first-column last-column
+            (sxml->string `(nu:message ,@msg))
+            (sxml->string `(nu:extract ,@extract)))]))
+
+(define (main args)
+  (define pipe (open-pipe* OPEN_READ "html5validator"
+                           "--format" "xml"
+                           ;; "--verbose"
+                           "--show-warnings"
+                           "--"
+                           "selenium.xhtml"
+                           "raw.xhtml"
+                           ))
+  (define data (xml->sxml pipe
+                          #:trim-whitespace? #t
+                          #:namespaces
+                          '((nu . "http://n.validator.nu/messages/")
+                            (xhtml . "http://www.w3.org/1999/xhtml"))))
+  (close-pipe pipe)
+  (let ((filtered-data
+          (filter (negate ignore-rule)
+                  ((sxpath '(// nu:messages *)) data))))
+    (if (null? filtered-data)
+        (begin
+          (display "Everything fine!")
+          (newline)
+          (exit 0))
+        (begin
+         (for-each (lambda (group)
+                     (format #t "~a~%" (-> group car (assoc-ref 'url) car))
+                     (for-each display-entry (cadr group)))
+                   (group-by-file filtered-data))
+         (exit 1)))))