115 lines
3.4 KiB
Scheme
115 lines
3.4 KiB
Scheme
(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)))
|