Add JSON API for route matching and TCB list
y5nw
parent
c10e06674c
commit
d7bff59e1c
|
|
@ -3,6 +3,8 @@
|
|||
(:export :program-entry))
|
||||
(in-package :ywatds)
|
||||
|
||||
(defparameter *ildb* nil)
|
||||
|
||||
(defun program-entry ()
|
||||
(let* ((argv (uiop:command-line-arguments))
|
||||
(worldpath (uiop:ensure-pathname (car argv)
|
||||
|
|
@ -14,16 +16,49 @@
|
|||
(server (make-instance 'easy-routes:routes-acceptor
|
||||
:port serverport)))
|
||||
(macrolet ((savefilepath (n)
|
||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n))))
|
||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
||||
(load-data ()
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls"))))))
|
||||
(ywsw:safe-text-route
|
||||
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||
(format nil "~s" (atsl:from-file (savefilepath p) :alist)))
|
||||
(ywsw:safe-text-route
|
||||
("/pretty_dump/interlocking" :method :get) ()
|
||||
(format nil "~s" (atil:import-data (savefilepath "interlocking.ls"))))
|
||||
(format nil "~s" *ildb*))
|
||||
(ywsw:safe-json-route ("/tcbinfo" :method :get) () *ildb*)
|
||||
(ywsw:safe-json-route
|
||||
("/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))
|
||||
(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)))))
|
||||
(hunchentoot:start server)
|
||||
;; loop until an error occurs
|
||||
(handler-case (loop (sleep most-positive-fixnum))
|
||||
(handler-case (loop do
|
||||
(load-data)
|
||||
(sleep 20))
|
||||
(t (c) (format t "~&~a~%" c)))
|
||||
(ignore-errors
|
||||
(hunchentoot:stop server)
|
||||
|
|
|
|||
12
helpers.lisp
12
helpers.lisp
|
|
@ -29,6 +29,12 @@
|
|||
(print-unreadable-object (obj stream)
|
||||
(format stream "~a,~a,~a" x y z))))
|
||||
|
||||
(defmethod json:encode-json ((obj v3d) &optional json:*json-output*)
|
||||
(with-accessors ((x v3d-x) (y v3d-y) (z v3d-z)) obj
|
||||
(json:encode-json (list (cons "x" x)
|
||||
(cons "y" y)
|
||||
(cons "z" z)))))
|
||||
|
||||
(defmacro string-to-v3d (str)
|
||||
(alexandria:with-gensyms (xs ys zs)
|
||||
`(cl-ppcre:register-groups-bind
|
||||
|
|
@ -45,3 +51,9 @@
|
|||
`(make-v3d :x (gethash "x" ,ht)
|
||||
:y (gethash "y" ,ht)
|
||||
:z (gethash "z" ,ht))))
|
||||
|
||||
(defmacro v3d-to-string (obj)
|
||||
(alexandria:with-gensyms (x y z)
|
||||
`(with-accessors ((,x v3d-x) (,y v3d-y) (,z v3d-z))
|
||||
,obj
|
||||
(format nil "(~a,~a,~a)" ,x ,y ,z))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,15 @@
|
|||
(defpackage :advtrains-interlocking
|
||||
(:use :cl)
|
||||
(:nicknames :atil)
|
||||
(:export :import-data))
|
||||
(:export :import-data
|
||||
:ars-rule :ars-rule-p :ars-rule-match-mode :ars-rule-match-string
|
||||
:ars-rule-invert-match
|
||||
:tcbside :tcbside-p :tcbside-pos :tcbside-side
|
||||
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
||||
:route :route-p :route-name :route-ars-rules :route-path
|
||||
:tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes
|
||||
:tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b
|
||||
:match-ars-p :match-route :route-next :find-tcb-at))
|
||||
(in-package :atil)
|
||||
|
||||
(defstruct ars-rule
|
||||
|
|
@ -21,6 +29,22 @@
|
|||
(:ln (format t "ARS RULE~:[~; NOT~] MATCHING LINE ~s" neg match))
|
||||
(:rc (format t "ARS RULE~:[~; NOT~] MATCHING RC ~s" neg match))))))
|
||||
|
||||
(defmethod json:encode-json ((obj ars-rule) &optional json:*json-output*)
|
||||
(with-accessors ((mode ars-rule-match-mode)
|
||||
(match ars-rule-match-string)
|
||||
(neg ars-rule-invert-match))
|
||||
obj
|
||||
(json:encode-json (ecase mode
|
||||
(:default (list (cons "mode" "default")))
|
||||
(:comment (list (cons "mode" "comment")
|
||||
(cons "comment" match)))
|
||||
(:ln (list (cons "mode" "ln")
|
||||
(cons "ln" match)
|
||||
(cons "n" neg)))
|
||||
(:rc (list (cons "mode" "rc")
|
||||
(cons "rc" match)
|
||||
(cons "n" neg)))))))
|
||||
|
||||
(defstruct tcbside
|
||||
(:pos (error "No coordinates specified") :type aux:v3d)
|
||||
(:side (error "No side specified") :type symbol))
|
||||
|
|
@ -32,18 +56,32 @@
|
|||
(print-unreadable-object (obj s)
|
||||
(format s "SIDE ~a OF ~a" tside p)))))
|
||||
|
||||
(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
|
||||
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
||||
(let ((tside (ecase side (:a "a") (:b "B"))))
|
||||
(json:encode-json (list (cons "p" p) (cons "s" tside))))))
|
||||
|
||||
(defstruct path-entry
|
||||
(next (error "No coordinates specified for path") :type tcbside)
|
||||
(next nil :type (or null tcbside))
|
||||
(locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string))))
|
||||
|
||||
(defmethod print-object ((obj path-entry) s)
|
||||
(with-accessors ((next path-entry-next) (locks path-entry-locks))
|
||||
obj
|
||||
(print-unreadable-object (obj s)
|
||||
(format s "TO ~a" next)
|
||||
(format s "TO ~a" (or next "EOI"))
|
||||
(loop for (pos . st) across locks do
|
||||
(format s " ~_LOCKING ~a TO ~s" pos st)))))
|
||||
|
||||
(defmethod json:encode-json ((obj path-entry) &optional json:*json-output*)
|
||||
(with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
|
||||
(json:encode-json-alist (list (cons "next" next)
|
||||
(cons "locks" (loop with ht = (make-hash-table)
|
||||
for i across locks
|
||||
for (pos . st) = i
|
||||
do (setf (gethash pos ht) st)
|
||||
finally (return ht)))))))
|
||||
|
||||
(defstruct route
|
||||
(name "" :type string)
|
||||
(ars-rules (aux:adj-vector-of 'ars-rule) :type (vector ars-rule))
|
||||
|
|
@ -59,6 +97,12 @@
|
|||
(pprint-indent :block 1 s)
|
||||
(loop for i across path do (format s " ~_~a" i))))))
|
||||
|
||||
(defmethod json:encode-json ((obj route) &optional json:*json-output*)
|
||||
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
|
||||
(json:encode-json (list (cons "name" name)
|
||||
(cons "ars" ars)
|
||||
(cons "path" path)))))
|
||||
|
||||
(defstruct tcbdata
|
||||
(ts nil :type (or string null))
|
||||
(signal-pos nil :type (or aux:v3d null))
|
||||
|
|
@ -76,6 +120,15 @@
|
|||
(pprint-indent :block 1 s)
|
||||
(loop for i across routelist do (format s " ~_~a" i))))))
|
||||
|
||||
(defmethod json:encode-json ((obj tcbdata) &optional json:*json-output*)
|
||||
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name)
|
||||
(routelist tcbdata-routes))
|
||||
obj
|
||||
(json:encode-json (list (cons "in_section" ts)
|
||||
(cons "signal_pos" spos)
|
||||
(cons "signal_name" sname)
|
||||
(cons "routes" routelist)))))
|
||||
|
||||
(defstruct tcb
|
||||
(pos (error "no position specified") :type aux:v3d)
|
||||
(side-a (error "TCB has no side A") :type tcbdata)
|
||||
|
|
@ -86,6 +139,58 @@
|
|||
(print-unreadable-object (obj s)
|
||||
(format s "TCB AT ~a ~_SIDE A ~a ~_SIDE B ~a" pos a b))))
|
||||
|
||||
(defmethod json:encode-json ((obj tcb) &optional json:*json-output*)
|
||||
(with-accessors ((pos tcb-pos) (a tcb-side-a) (b tcb-side-b)) obj
|
||||
(json:encode-json (list (cons "pos" pos)
|
||||
(cons "a" a)
|
||||
(cons "b" b)))))
|
||||
|
||||
(defmacro match-ars-p (ars-rules ln rc)
|
||||
(alexandria:with-gensyms (i r s n)
|
||||
(alexandria:once-only
|
||||
(ars-rules ln rc)
|
||||
`(loop
|
||||
with ,r = nil
|
||||
while (not ,r)
|
||||
for ,i across ,ars-rules
|
||||
for ,s = (ars-rule-match-string ,i)
|
||||
for ,n = (ars-rule-invert-match ,i)
|
||||
do (setf ,r (or ,r (ecase (ars-rule-match-mode ,i)
|
||||
(:default t)
|
||||
(:comment nil)
|
||||
(:ln (if ,n (string/= ,s ,ln) (string= ,s ,ln)))
|
||||
(:rc (if ,n (not (search ,rc ,s)) (search ,rc ,s))))))
|
||||
finally (return ,r)))))
|
||||
|
||||
(defmacro match-route (routelist ln rc)
|
||||
(alexandria:with-gensyms (i r)
|
||||
(alexandria:once-only
|
||||
(routelist ln rc)
|
||||
`(loop
|
||||
with ,r = nil
|
||||
while (not ,r)
|
||||
for ,i across ,routelist
|
||||
when (match-ars-p (route-ars-rules ,i) ,ln ,rc)
|
||||
do (setf ,r ,i)
|
||||
finally (return ,r)))))
|
||||
|
||||
(defmacro route-next (route)
|
||||
(alexandria:with-gensyms (p)
|
||||
(alexandria:once-only
|
||||
(route)
|
||||
`(let ((,p (route-path ,route)))
|
||||
(path-entry-next (aref ,p (length ,p)))))))
|
||||
|
||||
(defmacro find-tcb-at (data pos)
|
||||
(alexandria:with-gensyms (i r)
|
||||
(alexandria:once-only
|
||||
(data pos)
|
||||
`(loop with ,r = nil while (not ,r)
|
||||
for ,i across ,data
|
||||
when (equalp (tcb-pos ,i) ,pos)
|
||||
do (setf ,r ,i)
|
||||
finally (return ,r)))))
|
||||
|
||||
(defmacro parse-route-locks (locksht)
|
||||
(alexandria:with-gensyms (ht locks k v pos st)
|
||||
`(loop
|
||||
|
|
@ -106,11 +211,10 @@
|
|||
for ,ent = (gethash ,i ,ht)
|
||||
while ,ent
|
||||
for ,next = (gethash "next" ,ent)
|
||||
while ,next
|
||||
for ,p = (aux:hash-table-to-v3d (gethash "p" ,next))
|
||||
and ,s = (ecase (gethash "s" ,next) (1 :a) (2 :b))
|
||||
for ,p = (if ,next (aux:hash-table-to-v3d (gethash "p" ,next)) nil)
|
||||
and ,s = (if ,next (ecase (gethash "s" ,next) (1 :a) (2 :b)) nil)
|
||||
and ,locks = (parse-route-locks (gethash "locks" ,ent))
|
||||
for ,tcbs = (make-tcbside :pos ,p :side ,s)
|
||||
for ,tcbs = (if (and ,p ,s) (make-tcbside :pos ,p :side ,s) nil)
|
||||
do (vector-push-extend (make-path-entry :next ,tcbs :locks ,locks)
|
||||
,path)
|
||||
finally (return ,path))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(defpackage :ywatds-server-wrapper
|
||||
(:use :cl)
|
||||
(:nicknames :ywsw)
|
||||
(:export :toxml :safe-text-route))
|
||||
(:export :toxml :safe-text-route :safe-json-route))
|
||||
(in-package :ywsw)
|
||||
|
||||
(defun toxml (l)
|
||||
|
|
@ -38,7 +38,16 @@
|
|||
|
||||
(defmacro safe-text-route (options params &body body)
|
||||
(let ((name (gensym)) (response (gensym)))
|
||||
`(easy-routes:defroute ,name ,options ,params
|
||||
(setf (hunchentoot:content-type*) "text/plain")
|
||||
(let ((,response (safe-route ,@body)))
|
||||
(if (stringp ,response) ,response nil)))))
|
||||
`(easy-routes:defroute
|
||||
,name ,options ,params
|
||||
(setf (hunchentoot:content-type*) "text/plain")
|
||||
(let ((,response (safe-route ,@body)))
|
||||
(if (stringp ,response) ,response nil)))))
|
||||
|
||||
(defmacro safe-json-route (options params &body body)
|
||||
(alexandria:with-gensyms (name response)
|
||||
`(easy-routes:defroute
|
||||
,name ,options ,params
|
||||
(setf (hunchentoot:content-type*) "application/json")
|
||||
(let ((,response (safe-route (json:encode-json-to-string (progn ,@body)))))
|
||||
(if (stringp ,response) ,response "null")))))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
:version "0.1"
|
||||
:author "Y.W."
|
||||
:license "GNU AGPL 3 or later"
|
||||
:depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria")
|
||||
:depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria" "cl-json")
|
||||
:serial t
|
||||
:components ((:file "helpers")
|
||||
(:file "serialize-lib")
|
||||
|
|
|
|||
Loading…
Reference in New Issue