Code cleanup; add route for generating a diagram of interlocking routes
parent
c41f1be44a
commit
3a3a9d2020
|
@ -65,7 +65,19 @@
|
||||||
(t route))))
|
(t route))))
|
||||||
(t tcbs))))
|
(t tcbs))))
|
||||||
(t tcb)))))
|
(t tcb)))))
|
||||||
(easy-routes:defroute
|
(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:defsafe
|
||||||
docroute-master ("/doc" :method :get) ()
|
docroute-master ("/doc" :method :get) ()
|
||||||
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
||||||
for s = (string-downcase (string i))
|
for s = (string-downcase (string i))
|
||||||
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
(defpackage :graphviz
|
||||||
|
(:use :cl)
|
||||||
|
(:nicknames :gv)
|
||||||
|
(:export :string->svg))
|
||||||
|
(in-package :graphviz)
|
||||||
|
|
||||||
|
;;;; This package is currently set up as a workaround
|
||||||
|
(defun string->svg (string)
|
||||||
|
(with-input-from-string (*standard-input* string)
|
||||||
|
(uiop:run-program "/usr/bin/dot -Tsvg" :output :string :input t)))
|
|
@ -2,13 +2,13 @@
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
(:nicknames :atil)
|
(:nicknames :atil)
|
||||||
(:export :import-data
|
(:export :import-data
|
||||||
:ars-rule :ars-rule-p :ars-rule-match-mode :ars-rule-match-string
|
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
|
||||||
:ars-rule-invert-match
|
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
|
||||||
:tcbside :tcbside-p :tcbside-pos :tcbside-side
|
|
||||||
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
||||||
:route :route-p :route-name :route-ars-rules :route-path
|
:route :route-p :route-name :route-ars-rules :route-path
|
||||||
:tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes
|
:tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes
|
||||||
:tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b
|
:tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b
|
||||||
|
:ildb :ildb-p :ildb-tcbs
|
||||||
:match-ars-p :match-route :route-next :find-tcb-at))
|
:match-ars-p :match-route :route-next :find-tcb-at))
|
||||||
(in-package :atil)
|
(in-package :atil)
|
||||||
|
|
||||||
|
@ -39,10 +39,9 @@
|
||||||
(:side (error "No side specified") :type (integer 0 1)))
|
(:side (error "No side specified") :type (integer 0 1)))
|
||||||
|
|
||||||
(defmethod print-object ((obj tcbside) s)
|
(defmethod print-object ((obj tcbside) s)
|
||||||
(with-accessors ((p tcbside-pos) (side tcbside-side))
|
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
||||||
obj
|
|
||||||
(print-unreadable-object (obj s)
|
(print-unreadable-object (obj s)
|
||||||
(format s "SIDE ~a OF ~a" side p))))
|
(format s "~a/~a" p side))))
|
||||||
|
|
||||||
(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
|
(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
|
||||||
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
||||||
|
@ -53,8 +52,7 @@
|
||||||
(locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string))))
|
(locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string))))
|
||||||
|
|
||||||
(defmethod print-object ((obj path-entry) s)
|
(defmethod print-object ((obj path-entry) s)
|
||||||
(with-accessors ((next path-entry-next) (locks path-entry-locks))
|
(with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
|
||||||
obj
|
|
||||||
(print-unreadable-object (obj s)
|
(print-unreadable-object (obj s)
|
||||||
(format s "TO ~a" (or next "EOI"))
|
(format s "TO ~a" (or next "EOI"))
|
||||||
(loop for (pos . st) across locks do
|
(loop for (pos . st) across locks do
|
||||||
|
@ -75,8 +73,7 @@
|
||||||
(path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
|
(path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
|
||||||
|
|
||||||
(defmethod print-object ((obj route) s)
|
(defmethod print-object ((obj route) s)
|
||||||
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path))
|
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
|
||||||
obj
|
|
||||||
(print-unreadable-object (obj s)
|
(print-unreadable-object (obj s)
|
||||||
(format s "ROUTE ~:_~:i~s" name)
|
(format s "ROUTE ~:_~:i~s" name)
|
||||||
(cond
|
(cond
|
||||||
|
@ -134,6 +131,18 @@
|
||||||
(cons "a" a)
|
(cons "a" a)
|
||||||
(cons "b" b)))))
|
(cons "b" b)))))
|
||||||
|
|
||||||
|
(defstruct ildb
|
||||||
|
(tcbs (error "no TCB data") :type hash-table))
|
||||||
|
|
||||||
|
(defmethod print-object ((obj ildb) s)
|
||||||
|
(with-accessors ((tcbs ildb-tcbs)) obj
|
||||||
|
(print-unreadable-object (obj s)
|
||||||
|
(format s "TCBS ~s" (alexandria:hash-table-alist tcbs)))))
|
||||||
|
|
||||||
|
(defmethod json:encode-json ((obj ildb) &optional json:*json-output*)
|
||||||
|
(with-accessors ((tcbs ildb-tcbs)) obj
|
||||||
|
(json:encode-json (list (cons "tcbs" (alexandria:hash-table-alist tcbs))))))
|
||||||
|
|
||||||
(defmacro match-ars-p (ars-rules ln rc)
|
(defmacro match-ars-p (ars-rules ln rc)
|
||||||
(alexandria:with-gensyms (i r s n)
|
(alexandria:with-gensyms (i r s n)
|
||||||
(alexandria:once-only
|
(alexandria:once-only
|
||||||
|
@ -168,17 +177,10 @@
|
||||||
(alexandria:once-only
|
(alexandria:once-only
|
||||||
(route)
|
(route)
|
||||||
`(let ((,p (route-path ,route)))
|
`(let ((,p (route-path ,route)))
|
||||||
(path-entry-next (aref ,p (length ,p)))))))
|
(path-entry-next (aref ,p (1- (length ,p))))))))
|
||||||
|
|
||||||
(defmacro find-tcb-at (data pos)
|
(defmacro find-tcb-at (ildb pos)
|
||||||
(alexandria:with-gensyms (i r)
|
`(gethash ,pos (ildb-tcbs ,ildb)))
|
||||||
(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)
|
(defmacro parse-route-locks (locksht)
|
||||||
(alexandria:with-gensyms (ht locks k v pos st)
|
(alexandria:with-gensyms (ht locks k v pos st)
|
||||||
|
@ -245,7 +247,7 @@
|
||||||
|
|
||||||
(defun import-data (fn)
|
(defun import-data (fn)
|
||||||
(atsl:with-data-from-file (ht fn :hash-table)
|
(atsl:with-data-from-file (ht fn :hash-table)
|
||||||
(let ((tcbs (aux:adj-vector-of 'tcb)))
|
(let ((tcbs (make-hash-table :test #'equalp)))
|
||||||
(loop
|
(loop
|
||||||
for poss being each hash-key of (gethash "tcbs" ht)
|
for poss being each hash-key of (gethash "tcbs" ht)
|
||||||
using (hash-value tcb)
|
using (hash-value tcb)
|
||||||
|
@ -253,5 +255,5 @@
|
||||||
and side-a = (read-tcb-side (gethash 1 tcb))
|
and side-a = (read-tcb-side (gethash 1 tcb))
|
||||||
and side-b = (read-tcb-side (gethash 2 tcb))
|
and side-b = (read-tcb-side (gethash 2 tcb))
|
||||||
for tcbobj = (make-tcb :pos pos :side-a side-a :side-b side-b)
|
for tcbobj = (make-tcb :pos pos :side-a side-a :side-b side-b)
|
||||||
do (vector-push-extend tcbobj tcbs))
|
do (setf (gethash pos tcbs) tcbobj))
|
||||||
tcbs)))
|
(make-ildb :tcbs tcbs))))
|
||||||
|
|
|
@ -1,10 +1,13 @@
|
||||||
(defpackage :ywatds-server-wrapper
|
(defpackage :ywatds-server-wrapper
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
(:nicknames :ywsw)
|
(:nicknames :ywsw)
|
||||||
(:export :toxml :wrap-html
|
(:export :toxml :wrap-html :defsafe
|
||||||
:safe-text-route :safe-json-route))
|
:safe-text-route :safe-json-route :safe-graphviz-route))
|
||||||
(in-package :ywsw)
|
(in-package :ywsw)
|
||||||
|
|
||||||
|
(defmacro with-content-type (ctype &body body)
|
||||||
|
`(progn (setf (hunchentoot:content-type*) ,ctype) ,@body))
|
||||||
|
|
||||||
(defun toxml (l)
|
(defun toxml (l)
|
||||||
(cond
|
(cond
|
||||||
((null l) "")
|
((null l) "")
|
||||||
|
@ -40,6 +43,9 @@
|
||||||
(hunchentoot:log-message* :error (format nil "~a" ,c))
|
(hunchentoot:log-message* :error (format nil "~a" ,c))
|
||||||
nil))))
|
nil))))
|
||||||
|
|
||||||
|
(defmacro defsafe (name options params &body body)
|
||||||
|
`(easy-routes:defroute ,name ,options ,params (safe-route ,@body)))
|
||||||
|
|
||||||
(defmacro with-documentation ((name options params desc) &body body)
|
(defmacro with-documentation ((name options params desc) &body body)
|
||||||
(alexandria:with-gensyms (docroute)
|
(alexandria:with-gensyms (docroute)
|
||||||
(let ((lowername (string-downcase (string name)))
|
(let ((lowername (string-downcase (string name)))
|
||||||
|
@ -48,7 +54,7 @@
|
||||||
(if (listp options) (car options) options)
|
(if (listp options) (car options) options)
|
||||||
"</b><i>\\1</i><b>")))
|
"</b><i>\\1</i><b>")))
|
||||||
`(progn
|
`(progn
|
||||||
(easy-routes:defroute
|
(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)
|
||||||
|
@ -70,8 +76,7 @@
|
||||||
|
|
||||||
(defmacro safe-text-route (name options params doc &body body)
|
(defmacro safe-text-route (name options params doc &body body)
|
||||||
(let ((response (gensym)))
|
(let ((response (gensym)))
|
||||||
`(with-documentation
|
`(with-documentation (,name ,options ,params ,doc)
|
||||||
(,name ,options ,params ,doc)
|
|
||||||
(easy-routes:defroute
|
(easy-routes:defroute
|
||||||
,name ,options ,params
|
,name ,options ,params
|
||||||
(setf (hunchentoot:content-type*) "text/plain")
|
(setf (hunchentoot:content-type*) "text/plain")
|
||||||
|
@ -80,10 +85,18 @@
|
||||||
|
|
||||||
(defmacro safe-json-route (name options params doc &body body)
|
(defmacro safe-json-route (name options params doc &body body)
|
||||||
(alexandria:with-gensyms (response)
|
(alexandria:with-gensyms (response)
|
||||||
`(with-documentation
|
`(with-documentation (,name ,options ,params ,doc)
|
||||||
(,name ,options ,params ,doc)
|
|
||||||
(easy-routes:defroute
|
(easy-routes:defroute
|
||||||
,name ,options ,params
|
,name ,options ,params
|
||||||
(setf (hunchentoot:content-type*) "application/json")
|
(setf (hunchentoot:content-type*) "application/json")
|
||||||
(let ((,response (safe-route (json:encode-json-to-string (progn ,@body)))))
|
(let ((,response (safe-route (json:encode-json-to-string (progn ,@body)))))
|
||||||
(if (stringp ,response) ,response "null"))))))
|
(if (stringp ,response) ,response "null"))))))
|
||||||
|
|
||||||
|
(defmacro safe-graphviz-route (name options params doc &body body)
|
||||||
|
(alexandria:with-gensyms (response)
|
||||||
|
`(with-documentation (,name ,options ,params ,doc)
|
||||||
|
(easy-routes:defroute
|
||||||
|
,name ,options ,params
|
||||||
|
(setf (hunchentoot:content-type*) "image/svg+xml")
|
||||||
|
(let ((,response (progn ,@body)))
|
||||||
|
(if (stringp ,response) (gv:string->svg ,response) ""))))))
|
||||||
|
|
|
@ -7,6 +7,7 @@
|
||||||
:depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria" "cl-json")
|
:depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria" "cl-json")
|
||||||
:serial t
|
:serial t
|
||||||
:components ((:file "helpers")
|
:components ((:file "helpers")
|
||||||
|
(:file "graphviz")
|
||||||
(:file "serialize-lib")
|
(:file "serialize-lib")
|
||||||
(:file "interlocking")
|
(:file "interlocking")
|
||||||
(:file "server-wrapper")
|
(:file "server-wrapper")
|
||||||
|
|
Loading…
Reference in New Issue