122 lines
4.8 KiB
Common Lisp
122 lines
4.8 KiB
Common Lisp
(defpackage :ywatds
|
|
(:use :cl)
|
|
(:export :program-entry))
|
|
(in-package :ywatds)
|
|
|
|
(defparameter *ildb* nil)
|
|
(defparameter *nodedb* nil)
|
|
(defparameter *trackdb* nil)
|
|
|
|
(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 ()
|
|
`(progn
|
|
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
|
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
|
(setf *trackdb* (tracks:import-data *nodedb*))
|
|
(if (not debugp) (setf *nodedb* nil))
|
|
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
|
(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/tracks" :method :get) ()
|
|
("Return a simple graph of tracks")
|
|
(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
|
|
(handler-case (loop do
|
|
(load-data)
|
|
(sleep 20))
|
|
(t (c)
|
|
(format t "~&~a~%" c)
|
|
(when debugp (uiop:handle-fatal-condition c))))
|
|
(ignore-errors
|
|
(hunchentoot:stop server)
|
|
(uiop:quit)))))
|