From a313eed22e7c4f222e5101b96df27d98e5a0ed1d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Tue, 15 Mar 2022 01:37:05 +0100
Subject: Add JS user config for hyperlinking locations at LiU.

This is rather specific to me, but we already have the president with
the bundled config.scm file.
---
 scripts/fetch-liu-map-index.scm | 53 +++++++++++++++++++++++++++++++++++++++++
 static/user/.gitignore          |  1 +
 static/user/user-additions.js   | 37 ++++++++++++++++++++++++++++
 3 files changed, 91 insertions(+)
 create mode 100755 scripts/fetch-liu-map-index.scm

diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm
new file mode 100755
index 00000000..eea2a63d
--- /dev/null
+++ b/scripts/fetch-liu-map-index.scm
@@ -0,0 +1,53 @@
+#!/usr/bin/guile \
+-s
+!#
+
+;;; Commentary:
+;; Bulids an index of "all" locations at LiU, and prints it as a JSON
+;; object on the form { "location name": "url-fragment", ... }. These
+;; fragments should be appended to the base "https://old.liu.se/karta/".
+;;
+;; See static/user/user-additions.js for this script in action.
+;;; Code:
+
+(use-modules (srfi srfi-1)
+             (web client)
+             (web response)
+             (ice-9 rdelim)
+             (ice-9 format)
+             (sxml gumbo)
+             (sxml match)
+             (json))
+
+(define-values (response body) (http-get "https://old.liu.se/karta/list?l=sv"))
+
+(unless (= 200 (response-code response))
+  (format #t "Fetching index failed with ~a ~a~%"
+          (response-code response)
+          (response-reason-phrase response))
+  (format #t "~{~s~%~}" (response-headers response))
+  (exit 1))
+
+(define data (html->sxml body))
+
+(define rx (make-regexp "^karta\\?"))
+
+(define links
+  (map (lambda (node)
+         (sxml-match node
+                     [(a (@ (href ,href)) ,b0 ,body ...)
+                      (cons href b0)]))
+       (((@ (sxml xpath) sxpath) '(// a)) data)))
+
+(define map-links (filter (lambda (pair) (regexp-exec rx (car pair)))
+                          links))
+
+(define link-table (make-hash-table))
+(for-each (lambda (pair) (hash-set! link-table (string-upcase (string-trim-both (cdr pair)))
+                               (car pair)))
+          map-links)
+
+(scm->json (hash-map->list (lambda (name frag)
+                             `(,name . ,frag))
+                           link-table))
+(newline)
diff --git a/static/user/.gitignore b/static/user/.gitignore
index d4aa116a..6039f77d 100644
--- a/static/user/.gitignore
+++ b/static/user/.gitignore
@@ -1 +1,2 @@
 !*.js
+salar.json
diff --git a/static/user/user-additions.js b/static/user/user-additions.js
index 59a6248d..3b39b3ad 100644
--- a/static/user/user-additions.js
+++ b/static/user/user-additions.js
@@ -9,3 +9,40 @@ window.formatters.set('description', (el, d) => {
         el.innerHTML = d.replaceAll(/https?:\/\/\S+/g, '<a href="$&">$&</a>');
     }
 })
+
+/* This location formatter is generally not for general use.
+   It holds a small lookup table of "all" locations at Linköping University,
+   and makes location names from their calendar system clickable.
+
+   To obtain salar.json, run scripts/fetch-liu-map-index.scm from calps source tree.
+*/
+
+window.salar = new Promise((resolve, reject) =>
+    fetch('/static/user/salar.json')
+    .then(d => d.json())
+    .then(d => resolve(d)))
+
+
+window.formatters.set('location', async function(el, d) {
+    let rx = /Lokal: (.*)/
+    let m = rx.exec(d)
+    if (! m) {
+        el.textContent = d;
+        return;
+    }
+
+    let salar = await window.salar;
+
+    let name = m[1]
+    let frag = salar[name];
+    if (frag) {
+        let anch = document.createElement('a');
+        anch.href = `https://old.liu.se/karta/${frag}`
+        anch.target = '_blank'
+        anch.textContent = name;
+        el.append('Lokal: ');
+        el.append(anch);
+    } else {
+        el.textContent = `Lokal: ${name}`
+    }
+})
-- 
cgit v1.2.3