178 lines
6.8 KiB
Common Lisp
178 lines
6.8 KiB
Common Lisp
(defpackage :ywatds
|
|
(:use :cl)
|
|
(:export :program-entry))
|
|
(in-package :ywatds)
|
|
|
|
;; Databases
|
|
(defparameter *ildb* nil)
|
|
(defparameter *trackdb* nil)
|
|
|
|
;; Command-line arguments
|
|
(defparameter *debugp* nil)
|
|
(defparameter *gcp* nil)
|
|
(defparameter *world-path* nil)
|
|
;; Note: do NOT change *server-port* and *server* at debug time
|
|
(defparameter *server-port* nil)
|
|
(defparameter *server* nil)
|
|
;; Note: please call (ywatds::update-savefile-paths) if you change the world path at runtime
|
|
(defparameter *ildb-path* nil)
|
|
(defparameter *nodedb-path* nil)
|
|
|
|
#+sbcl(declaim (sb-ext:always-bound *ildb* *trackdb* *ildb-path* *nodedb-path*
|
|
*debugp* *gcp* *world-path* *server-port* *server*))
|
|
|
|
(defmacro ensure-world-path (path)
|
|
`(uiop:ensure-pathname ,path :defaults (uiop:getcwd) :ensure-directory t
|
|
:want-existing t :ensure-absolute t))
|
|
|
|
(defmacro savefilepath (name)
|
|
`(uiop:subpathname *world-path* ,(if (stringp name)
|
|
(concatenate 'string "advtrains_" name)
|
|
`(concatenate 'string "advtrains_" ,name))))
|
|
|
|
(defun update-savefile-paths ()
|
|
(psetf *ildb-path* (savefilepath "interlocking.ls")
|
|
*nodedb-path* (savefilepath "ndb4.ls")))
|
|
|
|
(defun load-data ()
|
|
(let* ((ildb (atil:load-ildb *ildb-path*))
|
|
(tdb (tracks:load-trackdb *nodedb-path* ildb)))
|
|
(psetf *ildb* ildb *trackdb* tdb)
|
|
(when *gcp*
|
|
#+sbcl(sb-ext:gc :full t))
|
|
(hunchentoot:acceptor-log-message *server* :info "Database updated")))
|
|
|
|
(defmacro mainloop ()
|
|
`(loop (load-data) (sleep 20)))
|
|
|
|
(defun program-entry ()
|
|
(let ((argv (uiop:command-line-arguments)))
|
|
(setf *world-path* (ensure-world-path (car argv)))
|
|
(setf *server-port* (coerce (parse-integer (cadr argv)) '(integer 0 65535)))
|
|
(setf *debugp* (member "--debug" (cddr argv) :test #'string=))
|
|
(setf *gcp* (member "--force-periodic-gc" (cddr argv) :test #'string=))
|
|
(setf *server* (make-instance 'easy-routes:routes-acceptor :port *server-port*))
|
|
(register-routes)
|
|
(register-debugging-routes)
|
|
(start-server)))
|
|
|
|
(defun register-routes ()
|
|
(ywsw:safe-text-route
|
|
dumpser
|
|
("/dumpser/:p" :method :get) (&path (p 'string))
|
|
("Deserialize <code>advtrains_<i>p</i></code> into a possibly nested associated list and return the result")
|
|
(format nil "~s" (atsl:from-file (savefilepath p) :alist)))
|
|
(ywsw:safe-text-route
|
|
pretty-dump-interlocking
|
|
("/pretty-dump/interlocking" :method :get) ()
|
|
("Return the interlocking database that is in use")
|
|
(format nil "~s" *ildb*))
|
|
(ywsw:safe-text-route
|
|
pretty-dump-registered-tracks
|
|
("/pretty-dump/registered-tracks" :method :get) ()
|
|
("Return the list of tracks known to the server")
|
|
(tracks:dump-track-definitions))
|
|
(ywsw:safe-json-route
|
|
tcbinfo
|
|
("/tcbinfo" :method :get) ()
|
|
("Return a list of TCBs and associated information")
|
|
*ildb*)
|
|
(ywsw:safe-json-route
|
|
tcbinfo-pos
|
|
("/tcbinfo/:x/:y/:z" :method :get)
|
|
(&get
|
|
(ln :parameter-type 'string) (rc :parameter-type 'string)
|
|
(side :parameter-type 'string)
|
|
(next :parameter-type 'boolean)
|
|
&path (x 'integer) (y 'integer) (z 'integer))
|
|
("Return information on the TCB assigned to the track at (<i>x</i>,<i>y</i>,<i>z</i>). If <i>side</i> is provided, return only information related to side <i>side</i> of the TCB. If <i>ln</i> and/or <i>rc</i> is provided in addition to <i>side</i>, return the first route with ARS rule(s) matching the line <i>ln</i> or routing code <i>rc</i>. If <i>next</i> is specified in addition to <i>side</i> and any of <i>ln</i> and <i>rc</i>, return where the route ends.")
|
|
(if (and x y z)
|
|
(let ((tcb (atil:find-tcb-at *ildb* (aux:make-v3d :x x :y y :z z))))
|
|
(cond
|
|
((not tcb) nil)
|
|
(side
|
|
(let ((tcbs (cond
|
|
((string-equal side "a") (atil:tcb-side-a tcb))
|
|
((string-equal side "b") (atil:tcb-side-b tcb))
|
|
(t nil))))
|
|
(cond
|
|
((not tcbs) nil)
|
|
((or ln rc)
|
|
(let ((route (atil:match-route (atil:tcbdata-routes tcbs)
|
|
(or ln "") (or rc ""))))
|
|
(cond
|
|
((not route) nil)
|
|
(next (atil:route-next route))
|
|
(t route))))
|
|
(t tcbs))))
|
|
(t tcb)))))
|
|
(ywsw:safe-graphviz-route
|
|
graph-ilroutes ("/graph/ilroutes" :method :get) ()
|
|
("Return a simple graph of TCBs and available routes")
|
|
(format nil "digraph{~%~{\"~a\"->\"~a\";~%~}}"
|
|
(loop for pos being the hash-keys of (atil:ildb-tcbs *ildb*)
|
|
using (hash-value tcb)
|
|
append (loop with side = (atil:make-tcbside :pos pos :side 0)
|
|
for i across (atil:tcbdata-routes (atil:tcb-side-a tcb))
|
|
append (list side (atil:route-next i)))
|
|
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
|
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
|
append (list side (atil:route-next i))))))
|
|
(ywsw:safe-text-route
|
|
graph-tracks ("/graph/paths" :method :get) ()
|
|
("Return a simple graph of paths")
|
|
(tracks:gvdump *trackdb*))
|
|
(ywsw:safe-text-route
|
|
find-path ("/find-path/:from-pos/:from-side/:to-pos/:to-side" :method :get)
|
|
(&path (from-pos 'string) (from-side 'integer)
|
|
(to-pos 'string) (to-side 'integer))
|
|
("Find path between two entries in the track database")
|
|
(multiple-value-bind (path dist)
|
|
(tracks:dijkstra *trackdb*
|
|
(tracks:trackside (aux:string-to-v3d from-pos) from-side)
|
|
(tracks:trackside (aux:string-to-v3d to-pos) to-side))
|
|
(if path (format nil "Distance: ~a~%~{~#[~;To~:;From~] ~a~@{~%~#[~;To~:;Via~] ~a~}~}"
|
|
dist path)
|
|
"No path")))
|
|
(ywsw:defsafe
|
|
docroute-master ("/doc" :method :get) ()
|
|
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
|
for s = (string-downcase (string i))
|
|
when (string/= (subseq s 0 3) "doc")
|
|
collect s)))
|
|
(ywsw:wrap-html
|
|
"Documentation"
|
|
`("h2" () "Documentation")
|
|
`("ul" () ,@(loop for i in (stable-sort entries #'string<)
|
|
collect `("li" () ("a" ("href" ,(format nil "/doc/http-~a" i))
|
|
,i))))))))
|
|
|
|
(defun register-debugging-routes ()
|
|
(macrolet
|
|
((debug-routes (&body body)
|
|
`(progn ,@(loop for i in body collect
|
|
`(ywsw:safe-text-route
|
|
,(car i) ,(cadr i) ,(caddr i)
|
|
,(cons "<b>[Only available in debugging mode]</b> " (cadddr i))
|
|
(if *debugp* (progn ,@(cddddr i))
|
|
"Debugging mode is disabled. Please run the server with --debug or set ywatds::*debugp* to a non-nil value."))))))
|
|
(debug-routes
|
|
(debug-room ("/debug/room" :method :get) () ("Dumps the output of <code>(room t)</code>")
|
|
(with-output-to-string (*standard-output*) (room t)))
|
|
(debug-routes ("/debug/routes" :method :get) () ("List defined routes")
|
|
(with-output-to-string (s)
|
|
(describe easy-routes:*routes-mapper* s))))))
|
|
|
|
(defun start-server ()
|
|
(tracks:init-tracks)
|
|
(update-savefile-paths)
|
|
(if *debugp* (break))
|
|
(load-data)
|
|
(hunchentoot:start *server*)
|
|
;; loop until an error occurs
|
|
(if *debugp* (mainloop) (handler-case (mainloop)
|
|
(t (c) (format *error-output* "~&~a~%" c))))
|
|
(ignore-errors
|
|
(hunchentoot:stop *server*)
|
|
(uiop:quit)))
|