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 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100755 scripts/fetch-liu-map-index.scm

(limited to 'scripts')

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)
-- 
cgit v1.2.3