(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 "") (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)))