Reorganize entry point code
y5nw
parent
186c0c9dae
commit
a394b35ac4
253
dataserver.lisp
253
dataserver.lisp
|
|
@ -3,120 +3,151 @@
|
|||
(:export :program-entry))
|
||||
(in-package :ywatds)
|
||||
|
||||
;; Databases
|
||||
(defparameter *ildb* nil)
|
||||
(defparameter *nodedb* nil)
|
||||
(defparameter *trackdb* nil)
|
||||
(defparameter *trackdb-temp* nil)
|
||||
|
||||
;; Command-line arguments
|
||||
(defparameter *debugp* nil)
|
||||
(defparameter *world-path* nil)
|
||||
;; Note: do NOT change *server-port* and *server* at debug time
|
||||
(defparameter *server-port* nil)
|
||||
(defparameter *server* nil)
|
||||
|
||||
(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* (concatenate 'string "advtrains_" ,name)))
|
||||
|
||||
(defmacro load-data ()
|
||||
(alexandria:with-gensyms (tdb tdbtemp)
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||
(if *debugp* (progn (setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
||||
(multiple-value-bind (,tdb ,tdbtemp)
|
||||
(tracks:import-data *nodedb*)
|
||||
(psetf *trackdb* ,tdb *trackdb-temp* ,tdbtemp)))
|
||||
(setf *trackdb* (tracks:import-data (ndb:import-data (savefilepath "ndb4.ls")))))
|
||||
(hunchentoot:acceptor-log-message *server* :info "Database updated"))))
|
||||
|
||||
(defmacro mainloop ()
|
||||
`(loop (load-data) (sleep 20)))
|
||||
|
||||
(defun program-entry ()
|
||||
(let* ((argv (uiop:command-line-arguments))
|
||||
(worldpath (uiop:ensure-pathname (car argv)
|
||||
:defaults (uiop:getcwd)
|
||||
:ensure-directory t
|
||||
:want-existing t
|
||||
:ensure-absolute t))
|
||||
(serverport (parse-integer (cadr argv)))
|
||||
(debugp (member "--debug" (cddr argv) :test #'string=))
|
||||
(server (make-instance 'easy-routes:routes-acceptor
|
||||
:port serverport)))
|
||||
(macrolet ((savefilepath (n)
|
||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
||||
(load-data ()
|
||||
(alexandria:with-gensyms (tf tl)
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
||||
(multiple-value-bind (,tf ,tl) (tracks:import-data *nodedb*)
|
||||
(setf *trackdb* ,tf)
|
||||
(if debugp (setf *trackdb-temp* ,tl)))
|
||||
(if (not debugp) (setf *nodedb* nil))
|
||||
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
||||
(mainloop ()
|
||||
`(loop (load-data) (sleep 20))))
|
||||
(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-graphviz-route
|
||||
graph-tracks ("/graph/paths" :method :get) ()
|
||||
("Return a simple graph of paths")
|
||||
(tracks:gvdump *trackdb*))
|
||||
(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)))))))
|
||||
(tracks:init-tracks)
|
||||
(hunchentoot:start server)
|
||||
(hunchentoot:acceptor-log-message server :info "~s"
|
||||
(with-output-to-string (s)
|
||||
(describe easy-routes:*routes-mapper* s)))
|
||||
;; loop until an error occurs
|
||||
(if debugp (mainloop) (ignore-errors (mainloop)))
|
||||
(ignore-errors
|
||||
(hunchentoot:stop server)
|
||||
(uiop:quit)))))
|
||||
(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 *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-graphviz-route
|
||||
graph-tracks ("/graph/paths" :method :get) ()
|
||||
("Return a simple graph of paths")
|
||||
(tracks:gvdump *trackdb*))
|
||||
(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)
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@
|
|||
"</b><i>\\1</i><b>")))
|
||||
`(progn
|
||||
(defsafe
|
||||
,docroute ,(format nil "/doc/http_~a" lowername) ()
|
||||
,docroute ,(format nil "/doc/http-~a" lowername) ()
|
||||
(wrap-html
|
||||
,(format nil "API ~a" lowername)
|
||||
,(toxml-multiple
|
||||
|
|
|
|||
Loading…
Reference in New Issue