Reorganize entry point code
y5nw
parent
186c0c9dae
commit
a394b35ac4
253
dataserver.lisp
253
dataserver.lisp
|
|
@ -3,120 +3,151 @@
|
||||||
(:export :program-entry))
|
(:export :program-entry))
|
||||||
(in-package :ywatds)
|
(in-package :ywatds)
|
||||||
|
|
||||||
|
;; Databases
|
||||||
(defparameter *ildb* nil)
|
(defparameter *ildb* nil)
|
||||||
(defparameter *nodedb* nil)
|
(defparameter *nodedb* nil)
|
||||||
(defparameter *trackdb* nil)
|
(defparameter *trackdb* nil)
|
||||||
(defparameter *trackdb-temp* 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 ()
|
(defun program-entry ()
|
||||||
(let* ((argv (uiop:command-line-arguments))
|
(let ((argv (uiop:command-line-arguments)))
|
||||||
(worldpath (uiop:ensure-pathname (car argv)
|
(setf *world-path* (ensure-world-path (car argv)))
|
||||||
:defaults (uiop:getcwd)
|
(setf *server-port* (coerce (parse-integer (cadr argv)) '(integer 0 65535)))
|
||||||
:ensure-directory t
|
(setf *debugp* (member "--debug" (cddr argv) :test #'string=))
|
||||||
:want-existing t
|
(setf *server* (make-instance 'easy-routes:routes-acceptor :port *server-port*))
|
||||||
:ensure-absolute t))
|
(register-routes)
|
||||||
(serverport (parse-integer (cadr argv)))
|
(register-debugging-routes)
|
||||||
(debugp (member "--debug" (cddr argv) :test #'string=))
|
(start-server)))
|
||||||
(server (make-instance 'easy-routes:routes-acceptor
|
|
||||||
:port serverport)))
|
(defun register-routes ()
|
||||||
(macrolet ((savefilepath (n)
|
(ywsw:safe-text-route
|
||||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
dumpser
|
||||||
(load-data ()
|
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||||
(alexandria:with-gensyms (tf tl)
|
("Deserialize <code>advtrains_<i>p</i></code> into a possibly nested associated list and return the result")
|
||||||
`(progn
|
(format nil "~s" (atsl:from-file (savefilepath p) :alist)))
|
||||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
(ywsw:safe-text-route
|
||||||
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
pretty-dump-interlocking
|
||||||
(multiple-value-bind (,tf ,tl) (tracks:import-data *nodedb*)
|
("/pretty-dump/interlocking" :method :get) ()
|
||||||
(setf *trackdb* ,tf)
|
("Return the interlocking database that is in use")
|
||||||
(if debugp (setf *trackdb-temp* ,tl)))
|
(format nil "~s" *ildb*))
|
||||||
(if (not debugp) (setf *nodedb* nil))
|
(ywsw:safe-text-route
|
||||||
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
pretty-dump-registered-tracks
|
||||||
(mainloop ()
|
("/pretty-dump/registered-tracks" :method :get) ()
|
||||||
`(loop (load-data) (sleep 20))))
|
("Return the list of tracks known to the server")
|
||||||
(ywsw:safe-text-route
|
(tracks:dump-track-definitions))
|
||||||
dumpser
|
(ywsw:safe-json-route
|
||||||
("/dumpser/:p" :method :get) (&path (p 'string))
|
tcbinfo
|
||||||
("Deserialize <code>advtrains_<i>p</i></code> into a possibly nested associated list and return the result")
|
("/tcbinfo" :method :get) ()
|
||||||
(format nil "~s" (atsl:from-file (savefilepath p) :alist)))
|
("Return a list of TCBs and associated information")
|
||||||
(ywsw:safe-text-route
|
*ildb*)
|
||||||
pretty-dump-interlocking
|
(ywsw:safe-json-route
|
||||||
("/pretty_dump/interlocking" :method :get) ()
|
tcbinfo-pos
|
||||||
("Return the interlocking database that is in use")
|
("/tcbinfo/:x/:y/:z" :method :get)
|
||||||
(format nil "~s" *ildb*))
|
(&get
|
||||||
(ywsw:safe-text-route
|
(ln :parameter-type 'string) (rc :parameter-type 'string)
|
||||||
pretty-dump-registered-tracks
|
(side :parameter-type 'string)
|
||||||
("/pretty_dump/registered_tracks" :method :get) ()
|
(next :parameter-type 'boolean)
|
||||||
("Return the list of tracks known to the server")
|
&path (x 'integer) (y 'integer) (z 'integer))
|
||||||
(tracks:dump-track-definitions))
|
("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.")
|
||||||
(ywsw:safe-json-route
|
(if (and x y z)
|
||||||
tcbinfo
|
(let ((tcb (atil:find-tcb-at *ildb* (aux:make-v3d :x x :y y :z z))))
|
||||||
("/tcbinfo" :method :get) ()
|
(cond
|
||||||
("Return a list of TCBs and associated information")
|
((not tcb) nil)
|
||||||
*ildb*)
|
(side
|
||||||
(ywsw:safe-json-route
|
(let ((tcbs (cond
|
||||||
tcbinfo-pos
|
((string-equal side "a") (atil:tcb-side-a tcb))
|
||||||
("/tcbinfo/:x/:y/:z" :method :get)
|
((string-equal side "b") (atil:tcb-side-b tcb))
|
||||||
(&get
|
(t nil))))
|
||||||
(ln :parameter-type 'string) (rc :parameter-type 'string)
|
(cond
|
||||||
(side :parameter-type 'string)
|
((not tcbs) nil)
|
||||||
(next :parameter-type 'boolean)
|
((or ln rc)
|
||||||
&path (x 'integer) (y 'integer) (z 'integer))
|
(let ((route (atil:match-route (atil:tcbdata-routes tcbs)
|
||||||
("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.")
|
(or ln "") (or rc ""))))
|
||||||
(if (and x y z)
|
(cond
|
||||||
(let ((tcb (atil:find-tcb-at *ildb* (aux:make-v3d :x x :y y :z z))))
|
((not route) nil)
|
||||||
(cond
|
(next (atil:route-next route))
|
||||||
((not tcb) nil)
|
(t route))))
|
||||||
(side
|
(t tcbs))))
|
||||||
(let ((tcbs (cond
|
(t tcb)))))
|
||||||
((string-equal side "a") (atil:tcb-side-a tcb))
|
(ywsw:safe-graphviz-route
|
||||||
((string-equal side "b") (atil:tcb-side-b tcb))
|
graph-ilroutes ("/graph/ilroutes" :method :get) ()
|
||||||
(t nil))))
|
("Return a simple graph of TCBs and available routes")
|
||||||
(cond
|
(format nil "digraph{~{\"~a\"->\"~a\";~}}"
|
||||||
((not tcbs) nil)
|
(loop for pos being the hash-keys of (atil:ildb-tcbs *ildb*)
|
||||||
((or ln rc)
|
using (hash-value tcb)
|
||||||
(let ((route (atil:match-route (atil:tcbdata-routes tcbs)
|
append (loop with side = (atil:make-tcbside :pos pos :side 0)
|
||||||
(or ln "") (or rc ""))))
|
for i across (atil:tcbdata-routes (atil:tcb-side-a tcb))
|
||||||
(cond
|
append (list side (atil:route-next i)))
|
||||||
((not route) nil)
|
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
||||||
(next (atil:route-next route))
|
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
||||||
(t route))))
|
append (list side (atil:route-next i))))))
|
||||||
(t tcbs))))
|
(ywsw:safe-graphviz-route
|
||||||
(t tcb)))))
|
graph-tracks ("/graph/paths" :method :get) ()
|
||||||
(ywsw:safe-graphviz-route
|
("Return a simple graph of paths")
|
||||||
graph-ilroutes ("/graph/ilroutes" :method :get) ()
|
(tracks:gvdump *trackdb*))
|
||||||
("Return a simple graph of TCBs and available routes")
|
(ywsw:defsafe
|
||||||
(format nil "digraph{~{\"~a\"->\"~a\";~}}"
|
docroute-master ("/doc" :method :get) ()
|
||||||
(loop for pos being the hash-keys of (atil:ildb-tcbs *ildb*)
|
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
||||||
using (hash-value tcb)
|
for s = (string-downcase (string i))
|
||||||
append (loop with side = (atil:make-tcbside :pos pos :side 0)
|
when (string/= (subseq s 0 3) "doc")
|
||||||
for i across (atil:tcbdata-routes (atil:tcb-side-a tcb))
|
collect s)))
|
||||||
append (list side (atil:route-next i)))
|
(ywsw:wrap-html
|
||||||
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
"Documentation"
|
||||||
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
`("h2" () "Documentation")
|
||||||
append (list side (atil:route-next i))))))
|
`("ul" () ,@(loop for i in (stable-sort entries #'string<)
|
||||||
(ywsw:safe-graphviz-route
|
collect `("li" () ("a" ("href" ,(format nil "/doc/http-~a" i))
|
||||||
graph-tracks ("/graph/paths" :method :get) ()
|
,i))))))))
|
||||||
("Return a simple graph of paths")
|
|
||||||
(tracks:gvdump *trackdb*))
|
(defun register-debugging-routes ()
|
||||||
(ywsw:defsafe
|
(macrolet
|
||||||
docroute-master ("/doc" :method :get) ()
|
((debug-routes (&body body)
|
||||||
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
`(progn ,@(loop for i in body collect
|
||||||
for s = (string-downcase (string i))
|
`(ywsw:safe-text-route
|
||||||
when (string/= (subseq s 0 3) "doc")
|
,(car i) ,(cadr i) ,(caddr i)
|
||||||
collect s)))
|
,(cons "<b>[Only available in debugging mode]</b> " (cadddr i))
|
||||||
(ywsw:wrap-html
|
(if *debugp* (progn ,@(cddddr i))
|
||||||
"Documentation"
|
"Debugging mode is disabled. Please run the server with --debug or set ywatds::*debugp* to a non-nil value."))))))
|
||||||
`("h2" () "Documentation")
|
(debug-routes
|
||||||
`("ul" () ,@(loop for i in (stable-sort entries #'string<)
|
(debug-room ("/debug/room" :method :get) () ("Dumps the output of <code>(room t)</code>")
|
||||||
collect `("li" () ("a" ("href" ,(format nil "/doc/http_~a" i))
|
(with-output-to-string (*standard-output*) (room t)))
|
||||||
,i)))))))
|
(debug-routes ("/debug/routes" :method :get) () ("List defined routes")
|
||||||
(tracks:init-tracks)
|
(with-output-to-string (s)
|
||||||
(hunchentoot:start server)
|
(describe easy-routes:*routes-mapper* s))))))
|
||||||
(hunchentoot:acceptor-log-message server :info "~s"
|
|
||||||
(with-output-to-string (s)
|
(defun start-server ()
|
||||||
(describe easy-routes:*routes-mapper* s)))
|
(tracks:init-tracks)
|
||||||
;; loop until an error occurs
|
(hunchentoot:start *server*)
|
||||||
(if debugp (mainloop) (ignore-errors (mainloop)))
|
;; loop until an error occurs
|
||||||
(ignore-errors
|
(if *debugp* (mainloop) (handler-case (mainloop)
|
||||||
(hunchentoot:stop server)
|
(t (c) (format *error-output* "~&~a~%" c))))
|
||||||
(uiop:quit)))))
|
(ignore-errors
|
||||||
|
(hunchentoot:stop *server*)
|
||||||
|
(uiop:quit)))
|
||||||
|
|
|
||||||
|
|
@ -55,7 +55,7 @@
|
||||||
"</b><i>\\1</i><b>")))
|
"</b><i>\\1</i><b>")))
|
||||||
`(progn
|
`(progn
|
||||||
(defsafe
|
(defsafe
|
||||||
,docroute ,(format nil "/doc/http_~a" lowername) ()
|
,docroute ,(format nil "/doc/http-~a" lowername) ()
|
||||||
(wrap-html
|
(wrap-html
|
||||||
,(format nil "API ~a" lowername)
|
,(format nil "API ~a" lowername)
|
||||||
,(toxml-multiple
|
,(toxml-multiple
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue