yw05
/
ywatds
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial rewrite

master
y5nw 2021-09-06 12:41:24 +02:00
parent 6e31a1c2eb
commit cd73f82d47
17 changed files with 737 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.dir-locals.el Normal file
View File

@ -0,0 +1,3 @@
((css-mode (indent-tabs-mode . t)
(tab-width . 8)
(css-indent-offset . 8)))

2
README.md
View File

@ -1,6 +1,6 @@
ywatds - a simple server program that provides data based on advtrains savefiles
**Please note that this project is still WIP and experimental. Use at your own risk.**
**Please note that this project is still WIP and experimental. Use at your own risk. _Work is currently in progress to rewrite this set of programs in GNU Guile Scheme._**
## Usage

5
aux/math.scm Normal file
View File

@ -0,0 +1,5 @@
(define-module (aux math)
#:export (floor-exact))
(define (floor-exact n)
(floor (inexact->exact n)))

69
aux/v2d.scm Normal file
View File

@ -0,0 +1,69 @@
(define-module (aux v2d)
#:export (v2d?
v2d+ v2d- v2d* v2d/
v2d-floor
v2d-length v2d-extend-to-length
v2d-midpoint v2d-slope v2d-intersection))
(define (v2d? obj)
(and (pair? obj)
(real? (car obj)) (finite? (car obj))
(real? (cdr obj)) (finite? (cdr obj))))
(import (rnrs base (6)))
(define (ensure-v2d obj)
(if (pair? obj) (begin (assert (v2d? obj)) obj)
(ensure-v2d (cons obj obj))))
(define (v2d-map proc lst)
(let ((v2ds (map-in-order ensure-v2d lst)))
(ensure-v2d
(cons (apply proc (map-in-order car v2ds))
(apply proc (map-in-order cdr v2ds))))))
(define (v2d-length obj)
(let ((v2d (ensure-v2d obj)))
(sqrt (+ (expt (car v2d) 2) (expt (cdr v2d) 2)))))
(define (v2d+ . lst) (v2d-map + lst))
(define (v2d- . lst) (v2d-map - lst))
(define (v2d* . lst) (v2d-map * lst))
(define (v2d/ . lst) (v2d-map / lst))
(define (v2d-floor obj)
(let ((v2d (ensure-v2d obj)))
(cons (floor (inexact->exact (car v2d)))
(floor (inexact->exact (cdr v2d))))))
(define (v2d-extend-to-length v2d length)
(let* ((cur-length (v2d-length v2d))
(factor (/ length cur-length)))
(v2d* v2d factor)))
(define (v2d-midpoint obj1 obj2)
(v2d/ (v2d+ obj1 obj2) 2))
(define (v2d-slope obj)
(let ((v2d (ensure-v2d obj)))
(if (zero? (car v2d)) (inf) (/ (cdr v2d) (car v2d)))))
(define (v2d-intersection v2d1 v2d2 dir1 dir2)
(let* ((p1 (ensure-v2d v2d1)) (p2 (ensure-v2d v2d2))
(d1 (ensure-v2d dir1)) (d2 (ensure-v2d dir2))
(u1? (zero? (car d1))) (u2? (zero? (car d2))))
(cond
(u1? (if u2?
(if (= (cdr p1) (cdr p2)) #f (v2d-midpoint p1 p2))
(let* ((a (v2d-slope d2))
(b (cdr (v2d- p2 (v2d* (cons 1 a) (car p2))))))
(cons (car p1) (+ (* a (car p1)) b)))))
(u2? (v2d-intersection p2 p1 d2 d1))
(#t (let* ((a1 (v2d-slope d1)) (a2 (v2d-slope d2))
(b1 (cdr (v2d- p1 (v2d* (cons 1 a1) (car p1)))))
(b2 (cdr (v2d- p2 (v2d* (cons 1 a2) (car p2))))))
(if (= a1 a2)
#f
(let* ((x (/ (- b2 b1) (- a1 a2)))
(y (+ b1 (* a1 x))))
(cons x y))))))))

114
dataserver.scm Normal file
View File

@ -0,0 +1,114 @@
(include "paths.scm")
(use-modules (ice-9 regex)
(ice-9 textual-ports)
(ice-9 binary-ports)
(ice-9 threads)
(srfi srfi-19)
(sxml simple)
(web request) (web response) (web server) (web uri)
;; custom modules listed below
(tracks nodedb)
(webui html) (webui svg))
(define dataserver-handlers '())
;; taken from https://www.gnu.org/software/guile/manual/html_node/Web-Examples.html
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
(define (request-query request)
(let* ((qstring (or (uri-query (request-uri request)) ""))
(qstring-matches (list-matches "[^&]+" qstring))
(parse-element
(lambda (match)
(let* ((str (match:substring match))
(eq-pos (string-index str #\=)))
(if eq-pos
(cons (uri-decode (string-take str eq-pos))
(uri-decode (string-drop str (+ 1 eq-pos))))
(uri-decode str))))))
(map-in-order parse-element qstring-matches)))
(define* (respond body #:key
(status 200)
(content-type 'text/plain)
(extra-headers '()))
(let* ((content-type-data `(,content-type (charset . "utf-8"))))
(values
(build-response #:code status
#:headers `((content-type . ,content-type-data)
,@extra-headers))
body)))
(define* (respond-html body #:key
(status 200)
(extra-headers '()))
(let* ((page (apply build-html-page body)))
(respond (lambda (port)
(put-string port "<!DOCTYPE html>")
(sxml->xml page port))
#:status status
#:content-type 'text/html
#:extra-headers extra-headers)))
(define* (respond-svg body #:key
(status 200)
(extra-headers '()))
(let ((page (apply svg body)))
(respond (lambda (port) (sxml->xml page port))
#:status status
#:content-type 'image/svg+xml
#:extra-headers extra-headers)))
(define (handle-not-found request body)
(respond-html `("Not found" "The requested path "
(code ,(uri->string (request-uri request)))
" could not be found on this server.")
#:status 404))
(define (dataserver-handler request body)
(letrec* ((path (request-path-components request))
(query (request-query request))
(f (lambda (handlers)
(cond
((null? handlers) (handle-not-found request body))
((equal? (caar handlers) path)
((cdar handlers) query))
(#t (f (cdr handlers)))))))
(format #t "[~a] ~a ~s -> ~s~%"
(date->string (current-date) "~5")
(request-method request)
(uri->string (request-uri request))
path)
(f dataserver-handlers)))
(define (default-stylesheet-handler _)
(respond
(call-with-input-file "webui/style.css" get-string-all #:binary #t)
#:content-type 'text/css))
(define (default-icon-handler _)
(respond
(call-with-input-file "webui/favicon.ico" get-bytevector-all
#:binary #t)
#:content-type 'image/vnd.microsoft.icon))
(set! dataserver-handlers
(cons* `(("style.css") . ,default-stylesheet-handler)
`(("favicon.ico") . ,default-icon-handler)
dataserver-handlers))
;; Handlers
(include "webui/conns.scm")
(include "webui/registered-tracks.scm")
(include "webui/nodedb.scm")
(include "webui/perfdata.scm")
(define nodedb-path (string-append world-path "/advtrains_ndb4.ls"))
(define nodedb-dump-path (string-append script-path "/nodedb.svg"))
(define (load-data)
(load-nodedb nodedb-path))
(load-data)
(call-with-new-thread (lambda () (run-server dataserver-handler)))

7
paths.scm Normal file
View File

@ -0,0 +1,7 @@
(define script-path (dirname (current-filename)))
(define world-path (cadr (program-arguments)))
(let ((addf (lambda (x)
(add-to-load-path (string-append script-path "/" x)))))
(add-to-load-path script-path)
(for-each addf '("aux" "tracks" "webui")))

92
tracks/conns.scm Normal file
View File

@ -0,0 +1,92 @@
(define-module (tracks conns)
#:export (track-conns
conns-turnout conns-turnout-flat
conns-crossings conns-crossings-flat
track-dir-adjust track-conns-adjust track-clist-adjust
clist-optimize))
(use-modules (srfi srfi-1) (srfi srfi-69))
(define dir-objects (make-vector 32))
(do ((i 0 (1+ i))) ((> i 31))
(vector-set! dir-objects i `(,(ash i -1) . ,(bit-extract i 0 1))))
(define conns-objects (make-vector 1024))
(do ((i 0 (1+ i))) ((> i 1023))
(vector-set!
conns-objects i
`(,(vector-ref dir-objects (ash i -5)) .
,(vector-ref dir-objects (bit-extract i 0 5)))))
(define* (track-conns c1 c2 #:optional (r1 0) (r2 0))
(vector-ref conns-objects (+ (ash c1 6) (ash r1 5) (ash c2 1) r2)))
(define* (conns-turnout clist #:optional (rlist '()))
(let ((c1 (car clist)) (cr (cdr clist)))
(if (null? rlist)
(map-in-order (lambda (x) (track-conns c1 x)) cr)
(let ((r1 (car rlist)) (rr (cdr rlist)))
(map-in-order (lambda (c r) (track-conns c1 c r1 r)) cr rr)))))
(define (conns-turnout-flat . clist)
(conns-turnout clist))
(define* (conns-crossings clist #:optional (rlist '()))
(letrec ((f (lambda (lst cl rl)
(cond
((null? cl) lst)
((null? rl)
(f (cons (track-conns (car cl) (cadr cl)) lst)
(cddr cl) '()))
(#t (f (cons (track-conns (car cl) (cadr cl)
(car rl) (cadr rl))
lst) (cddr cl) (cddr rl)) '())))))
(reverse (f '() clist rlist))))
(define (conns-crossings-flat . clist)
(conns-crossings clist))
(define (track-dir-adjust-aux n offset)
(modulo (+ n offset) 16))
(define (track-dir-adjust dir offset)
(let ((c (track-dir-adjust-aux (car dir) offset))
(r (cdr dir)))
(vector-ref dir-objects (+ (* 2 c) r))))
(define (track-conns-adjust conns offset)
(let ((c1 (track-dir-adjust-aux (caar conns) offset))
(c2 (track-dir-adjust-aux (cadr conns) offset)))
(track-conns c1 c2 (cdar conns) (cddr conns))))
(define (track-clist-adjust clist offset)
(let ((f (lambda (x) (track-conns-adjust x offset))))
(map-in-order f clist)))
(define (conns->small-int conns)
(let* ((aux (lambda (from to)
(+ (ash (car from) 6) (ash (cdr from) 5)
(ash (car to) 1) (cdr to))))
(from (car conns)) (to (cdr conns)))
(if (> (car from) (car to)) (aux to from) (aux from to))))
(define clist-shared-objects (make-hash-table))
(define (clist-optimize clist)
(letrec* ((nlist (delete-duplicates!
(sort-list! (map conns->small-int clist) <)
=))
(get-shared-obj
(lambda (obj)
(if (null? obj) '()
(if (hash-table-exists? clist-shared-objects obj)
(hash-table-ref clist-shared-objects obj)
(let ((newobj
(cons (vector-ref conns-objects (car obj))
(cdr obj))))
(hash-table-set! clist-shared-objects obj newobj)
newobj)))))
(share-obj
(lambda (lst)
(if (null? lst) '()
(get-shared-obj
(cons (car lst) (share-obj (cdr lst))))))))
(share-obj nlist)))

63
tracks/nodedb.scm Normal file
View File

@ -0,0 +1,63 @@
(define-module (tracks nodedb)
#:export (nodedb
load-nodedb))
(use-modules (ice-9 binary-ports) (ice-9 textual-ports)
(rnrs bytevectors)
(srfi srfi-2) (srfi srfi-69)
(tracks register))
(define nodedb (make-hash-table))
(define (load-nodedb filename)
(letrec* ((names (make-vector 65536 #f))
(nodes (make-hash-table))
(read-bv
(lambda (port n)
(and-let* ((v (get-bytevector-n port n))
((not (eof-object? v)))
((= (bytevector-length v) n)))
v)))
(bo (endianness big))
(read-u16
(lambda (port)
(and-let* ((v (read-bv port 2)))
(bytevector-u16-ref v 0 bo))))
(balance (lambda (n) (- n 32768)))
(read-int
(lambda (port)
(and-let* ((n (read-u16 port)))
(balance n))))
(read-node-entry
(lambda (port)
(and-let* ((v (read-bv port 8))
(b (lambda (v i)
(balance (bytevector-u16-ref v i bo))))
(x (b v 0)) (y (b v 2)) (z (b v 4)) (id (b v 6))
(c (list x y z))
(n (+ (ash id -2) 32768))
(p (bit-extract id 0 2)))
(and-let* ((s (vector-ref names n)))
(hash-table-set! nodes c (vector-ref s p)))
#t)))
(read-node-definition
(lambda (port)
(let* ((k (read-u16 port)) (v (get-line port)))
(when (and v (hash-table-exists? registered-tracks v))
(vector-set! names k
(hash-table-ref registered-tracks v))))))
(read-node-definitions
(lambda (port)
(do ((i (read-int port) (- i 1))) ((zero? i))
(read-node-definition port))))
(read-nodes (lambda (port) (while (read-node-entry port))))
(read-ndb
(lambda (port)
(unless (equal? (get-u8 port) 1)
(error "wrong nodedb version"))
(read-node-definitions port)
(read-nodes port)
(set! nodedb nodes))))
(call-with-input-file filename read-ndb #:binary #t)
(format #t "Node database: ~d tracks in database~%"
(hash-table-size nodedb))))

109
tracks/register.scm Normal file
View File

@ -0,0 +1,109 @@
(define-module (tracks register)
#:export (registered-tracks))
(use-modules (srfi srfi-43) (srfi srfi-69) (tracks conns))
(define registered-tracks (make-hash-table string=? string-hash))
(define (register-track name clist)
(let* ((f (lambda (_ x) (clist-optimize (track-clist-adjust clist x))))
(d (vector 0 4 8 12)))
(vector-map! f d)
(hash-table-set! registered-tracks name d)))
(define (register-tracks names clist)
(let ((f (lambda (x) (register-track x clist))))
(if (list? names) (map f names) (f names))))
(define (register-rotatable-track name clist)
(let ((f (lambda (suffix offset)
(register-track (string-append name suffix)
(track-clist-adjust clist offset)))))
(map f '("" "_30" "_45" "_60") '(0 1 2 3))))
(define (register-rotatable-tracks names clist)
(let ((f (lambda (x) (register-rotatable-track x clist))))
(if (list? names) (map f names) (f names))))
(define (prefix-names prefix names)
(let ((f (lambda (x) (string-append prefix "_" x))))
(if (list? names) (map-in-order f names) (f names))))
(define (register-tracks-with-preset . defs)
(lambda (prefix)
(letrec ((f (lambda (lst)
(unless (null? lst)
(register-tracks (prefix-names prefix (car lst))
(cadr lst))
(f (cddr lst))))))
(f defs))))
(define (register-rotatable-tracks-with-preset . defs)
(lambda (prefix)
(letrec ((f (lambda (lst)
(unless (null? lst)
(register-rotatable-tracks
(prefix-names prefix (car lst))
(cadr lst))
(f (cddr lst))))))
(f defs))))
(define register-default-tracks
(register-rotatable-tracks-with-preset
"st" (conns-turnout-flat 0 8)
"cr" (conns-turnout-flat 0 7)
'("swlst" "swlcr") (conns-turnout-flat 0 8 7)
'("swrst" "swrcr") (conns-turnout-flat 0 8 9)))
(define register-y-turnout-tracks
(register-rotatable-tracks-with-preset
'("l" "r") (conns-turnout-flat 0 7 9)))
(define register-3way-turnout-tracks
(register-rotatable-tracks-with-preset
'("l" "s" "r") (conns-turnout-flat 0 7 8 9)))
(define register-slope-tracks
(register-rotatable-tracks-with-preset
'("vst1" "vst31" "vst32") (conns-turnout-flat 8 0)
'("vst2" "vst33") (conns-turnout '(8 0) '(0 1))))
(define register-straightonly-tracks
(register-rotatable-tracks-with-preset
"st" (conns-turnout-flat 0 8)))
(define register-perp-xing-tracks
(register-rotatable-tracks-with-preset
"st" (conns-crossings-flat 0 8 4 12)))
(define register-90+x-xing-tracks
(register-rotatable-tracks-with-preset
"30l" (conns-crossings-flat 0 8 1 9)
"45l" (conns-crossings-flat 0 8 2 10)
"60l" (conns-crossings-flat 0 8 3 11)
"60r" (conns-crossings-flat 0 8 5 13)
"45r" (conns-crossings-flat 0 8 6 14)
"30r" (conns-crossings-flat 0 8 7 15)))
(define register-diag-xing-tracks
(register-tracks-with-preset
"30l45r" (conns-crossings-flat 1 9 6 14)
"60l30l" (conns-crossings-flat 3 11 1 9)
"60l45r" (conns-crossings-flat 3 11 6 14)
"60l60r" (conns-crossings-flat 3 11 5 13)
"60r45l" (conns-crossings-flat 5 13 2 10)
"60r30r" (conns-crossings-flat 5 13 7 15)
"30r45l" (conns-crossings-flat 7 15 2 10)))
(register-default-tracks "advtrains:dtrack")
(register-y-turnout-tracks "advtrains:dtrack_sy")
(register-3way-turnout-tracks "advtrains:dtrack_s3")
(register-perp-xing-tracks "advtrains:dtrack_xing")
(register-90+x-xing-tracks "advtrains:dtrack_xing90plusx")
(register-diag-xing-tracks "advtrains:dtrack_xingdiag")
(register-slope-tracks "advtrains:dtrack")
(register-straightonly-tracks "advtrains:dtrack_bumper")
(register-straightonly-tracks "advtrains:dtrack_atc")
(register-straightonly-tracks "advtrains:dtrack_unload")
(register-straightonly-tracks "advtrains:dtrack_load")
(register-straightonly-tracks "advtrains:dtrack_detector_off")
(register-straightonly-tracks "advtrains:dtrack_detector_on")

173
webui/conns.scm Normal file
View File

@ -0,0 +1,173 @@
(use-modules (aux v2d) (aux math))
(define (conns-query->qstring qlist)
(let ((f (lambda (elem) (format #f "~d=~d" (car elem) (cdr elem)))))
(format #f "~{~a~^&~}" (map-in-order f qlist))))
(define (conns-handler-get-query qlist)
(let* ((valid-conns-string?
(lambda (str)
(and (string-every char-numeric? str)
(let ((snum (string->number str)))
(and (integer? snum) (< snum 16) (>= snum 0))))))
(query-filter
(lambda (elem)
(and (pair? elem)
(valid-conns-string? (car elem))
(valid-conns-string? (cdr elem)))))
(seen? (make-vector 256 #f))
(query-iter
(lambda (elem)
(and (query-filter elem)
(let* ((from (string->number (car elem)))
(to (string->number (cdr elem)))
(idx (+ (* 16 from) to)))
(and (not (vector-ref seen? idx))
(begin
(vector-set! seen? idx #t)
(cons from to))))))))
(delq! #f (map query-iter qlist))))
(define half-curve-memoization (make-vector 256 #f))
(define (clist->svg query)
(let* ((svg-size 512)
(adjust (lambda (x n) (modulo (+ x n) 16)))
(dir->pos-map
;; note that this vector maps north to -y
#((0 . -1) (1/2 . -1) (1 . -1) (1 . -1/2)
(1 . 0) (1 . 1/2) (1 . 1) (1/2 . 1)
(0 . 1) (-1/2 . 1) (-1 . 1) (-1 . 1/2)
(-1 . 0) (-1 . -1/2) (-1 . -1) (-1/2 . -1)))
(dir->pos (lambda (dir size)
(let ((pos-entry (vector-ref dir->pos-map dir)))
(v2d* (v2d+ pos-entry 1) size 1/2))))
(offset-pos (lambda (pos dir length)
(let ((ent (vector-ref dir->pos-map dir)))
(v2d+ (v2d-extend-to-length ent length) pos))))
(half-curve
(lambda (from to size width)
(let* ((idx (+ (* 16 from) to))
(memoization (vector-ref half-curve-memoization idx)))
(if memoization memoization
(let*
((aux (lambda (dir off)
(v2d-floor (offset-pos (dir->pos dir size)
(adjust dir off)
(/ width 2)))))
(p1 (aux from 4))
(p2 (aux to 12))
(p0 (v2d-floor (v2d+ (v2d*
(vector-ref dir->pos-map from)
width)
p1)))
(p3 (v2d-floor (v2d+ (v2d*
(vector-ref dir->pos-map to)
width)
p2)))
(d1 (v2d- (vector-ref dir->pos-map from)))
(d2 (v2d- (vector-ref dir->pos-map to)))
(c (v2d-intersection p1 p2 d1 d2))
(s (if c
(format
#f "~d~@dL~d~@dQ~d~@d~@d~@dL~d~@d"
(car p0) (cdr p0) (car p1) (cdr p1)
(floor-exact (car c))
(floor-exact (cdr c))
(car p2) (cdr p2) (car p3) (cdr p3))
(format
#f "~d~@dL~d~@dL~d~@dL~d~@d"
(car p0) (cdr p0) (car p1) (cdr p1)
(car p2) (cdr p2) (car p3) (cdr p3)))))
(vector-set! half-curve-memoization idx s)
s)))))
(make-path-entry
(lambda (elem)
(let* ((size svg-size)
(width (/ size 4))
(from (car elem))
(to (cdr elem))
(c1 (half-curve from to size width))
(c2 (half-curve to from size width)))
(if (and c1 c2)
(format #f "M~aL~aZ" c1 c2)
""))))
(path-string (string-concatenate (map make-path-entry query))))
`(,svg-size
,svg-size
(path (@ (d ,path-string)
(stroke "#000")
(stroke-width ,(floor-exact (/ svg-size 32)))
(fill "#be2d2c"))))))
(define (conns-handler-draw-svg original-query)
(let ((query (conns-handler-get-query original-query)))
(respond-svg (clist->svg query))))
(define (conns-handler-draw-preview-page original-query)
(let* ((dirnames
#("N" "NNE" "NE" "ENE" "E" "ESE" "SE" "SSE"
"S" "SSW" "SW" "WSW" "W" "WNW" "NW" "NNW"))
(query (conns-handler-get-query original-query))
(li-aux
(lambda (setter pair value)
(let ((cw (modulo (+ value 1) 16))
(ccw (modulo (+ value 15) 16)))
`((td (a (@ (href "/conns-preview?"
,(begin (setter pair ccw)
(conns-query->qstring query))))
"\u21b6"))
(td ,(format #f "~a" (vector-ref dirnames value)))
(td (a (@ (href "/conns-preview?"
,(begin (setter pair cw)
(conns-query->qstring query))))
"\u21b7"))
,(begin (setter pair value) "")))))
(colsep `(td (@ (style "margin:0;padding:0"))))
(rowsep `(tr (td (@ (style "margin:0;padding:0")
(colspan 9)))))
(li (lambda (elem)
`(tr
(td (a (@ (href "/conns-preview?"
,(conns-query->qstring
(delete elem query))))
"Delete"))
,colsep
,@(li-aux set-car! elem (car elem))
,colsep
,@(li-aux set-cdr! elem (cdr elem))))))
(respond-html
`("Conns preview"
(table (@ (class "standard-table align-center thick-table-borders")
(style "width:min-content"))
(tr (th "Action")
,colsep
(th (@ (colspan 3)) "From")
,colsep
(th (@ (colspan 3)) "To"))
,@(map-in-order li query)
(tr (td (a (@ (href "/conns-preview?"
,(conns-query->qstring
(append query '((0 . 8))))))
"(Add)"))
,colsep
(td (@ (class "unavailable") (colspan 3)) "N")
,colsep
(td (@ (class "unavailable") (colspan 3)) "S"))
,rowsep
(tr (th (@ (colspan 9)) "Preview"))
(tr (td (@ (colspan 9)
(style "margin:0;padding:0"))
(img (@ (src "/conns.svg?"
,(conns-query->qstring query))
(style "width:100%;height:auto;")))))
,rowsep
(tr (th (@ (colspan 9)) "Notes"))
(tr (td (@ (colspan 9)
(style "text-align:initial"))
"Duplicate entries are only shown once.")))))))
(set! dataserver-handlers
(cons* (cons '("conns.svg") conns-handler-draw-svg)
(cons '("conns-preview") conns-handler-draw-preview-page)
dataserver-handlers))

BIN
webui/favicon.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 70 B

26
webui/html.scm Normal file
View File

@ -0,0 +1,26 @@
(define-module (webui html)
#:export (build-html-page
html-h1 html-h2 html-h3 html-h4 html-h5 html-h6))
(use-modules (sxml simple))
(define (html header . body)
(let ((title (if (string? header) header (car header)))
(bodydata (if (pair? header) (cdr header) '())))
`(html (head (title ,title)
(link (@ (rel "stylesheet") (href "/style.css")))
,@bodydata)
(body ,@body))))
(define (make-simple-tag-wrapper tagname)
(lambda body
`(,tagname ,@body)))
(define html-h1 (make-simple-tag-wrapper 'h1))
(define html-h2 (make-simple-tag-wrapper 'h2))
(define html-h3 (make-simple-tag-wrapper 'h3))
(define html-h4 (make-simple-tag-wrapper 'h4))
(define html-h5 (make-simple-tag-wrapper 'h5))
(define html-h6 (make-simple-tag-wrapper 'h6))
(define (build-html-page title . body)
(html title body))

0
webui/nodedb.scm Normal file
View File

16
webui/perfdata.scm Normal file
View File

@ -0,0 +1,16 @@
(define (perfdata-handler _)
(let* ((stats (gc-stats))
(dump-alist-aux (lambda (entry)
`(tr (td ,(format #f "~a" (car entry)))
(td ,(format #f "~a" (cdr entry))))))
(dump-alist (lambda (lst)
(map dump-alist-aux lst))))
(respond-html
`("Performance information"
(table (@ (class "standard-table"))
(tr (th (@ (colspan 2)) "GC Stats"))
,(dump-alist stats))))))
(set! dataserver-handlers
(cons* `(("perfdata") . ,perfdata-handler)
dataserver-handlers))

33
webui/registered-tracks.scm Normal file
View File

@ -0,0 +1,33 @@
(use-modules (srfi srfi-69) (tracks conns) (tracks register))
(define (conns-handler-registered-tracks qlist)
(let* ((sortf (lambda (ent1 ent2)
(string< (car ent1) (car ent2))))
(tracks (sort-list! (hash-table->alist registered-tracks) sortf))
(clist-mapf (lambda (ent) (cons (caar ent) (cadr ent))))
(conns-cell
(lambda (clist)
`(td (img (@ (src "/conns.svg?"
,@(conns-query->qstring
(map clist-mapf clist))))))))
(make-track-entry
(lambda (ent)
(let* ((cvects (cdr ent))
(clists (vector->list cvects))
(cells (map-in-order conns-cell clists)))
`(tr (td ,(car ent))
,@cells))))
(track-entries (map-in-order make-track-entry tracks))
(style (string-append
"img{height:calc(1em + 20px);width:auto;display:block}"
"td:not(:first-child){padding:0 !important}")))
(respond-html
`(("Known tracks" (style ,style))
(table (@ (class "standard-table"))
(tr (th "Name")
(th (@ (colspan 4)) "Conns"))
,@track-entries)))))
(set! dataserver-handlers
(cons* (cons '("registered-tracks") conns-handler-registered-tracks)
dataserver-handlers))

18
webui/style.css Normal file
View File

@ -0,0 +1,18 @@
table.standard-table {
border: solid 1px black;
border-collapse: collapse;
}
table.standard-table th, table.standard-table td{
border: solid 1px black;
padding: 5px;
}
table.thick-table-borders.standard-table {
border:solid 2px black;
}
.align-center, .align-center * {
text-align: center;
}
.unavailable {
text-decoration: line-through;
color: gray;
}

8
webui/svg.scm Normal file
View File

@ -0,0 +1,8 @@
(define-module (webui svg)
#:export (svg))
(use-modules (sxml simple))
(define (svg width height . body)
`(svg (@ (xmlns . "http://www.w3.org/2000/svg")
(viewBox ("0 0 " ,width " " ,height)))
,@body))