Code cleanup; add route for generating a diagram of interlocking routes

dataserver.lisp

@@ -65,7 +65,19 @@
 			 (t route))))
 		    (t tcbs))))
 	       (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) ()
 	  (let ((entries (loop for i being the hash-keys of easy-routes::*routes*
 			    for s = (string-downcase (string i))

graphviz.lisp

@@ -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)))

interlocking.lisp

@@ -2,13 +2,13 @@
   (:use :cl)
   (:nicknames :atil)
   (: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
+	   :ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
+	   :tcbside :make-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
+	   :ildb :ildb-p :ildb-tcbs
 	   :match-ars-p :match-route :route-next :find-tcb-at))
 (in-package :atil)
 
@@ -39,10 +39,9 @@
   (:side (error "No side specified") :type (integer 0 1)))
 
 (defmethod print-object ((obj tcbside) s)
-  (with-accessors ((p tcbside-pos) (side tcbside-side))
-      obj
+  (with-accessors ((p tcbside-pos) (side tcbside-side)) obj
     (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*)
   (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))))
 
 (defmethod print-object ((obj path-entry) s)
-  (with-accessors ((next path-entry-next) (locks path-entry-locks))
-      obj
+  (with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
     (print-unreadable-object (obj s)
       (format s "TO ~a" (or next "EOI"))
       (loop for (pos . st) across locks do
@@ -75,8 +73,7 @@
   (path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
 
 (defmethod print-object ((obj route) s)
-  (with-accessors ((name route-name) (ars route-ars-rules) (path route-path))
-      obj
+  (with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
     (print-unreadable-object (obj s)
       (format s "ROUTE ~:_~:i~s" name)
       (cond
@@ -134,6 +131,18 @@
 			    (cons "a" a)
 			    (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)
   (alexandria:with-gensyms (i r s n)
     (alexandria:once-only
@@ -168,17 +177,10 @@
     (alexandria:once-only
      (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)
-  (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 find-tcb-at (ildb pos)
+  `(gethash ,pos (ildb-tcbs ,ildb)))
 
 (defmacro parse-route-locks (locksht)
   (alexandria:with-gensyms (ht locks k v pos st)
@@ -245,7 +247,7 @@
 
 (defun import-data (fn)
   (atsl:with-data-from-file (ht fn :hash-table)
-    (let ((tcbs (aux:adj-vector-of 'tcb)))
+    (let ((tcbs (make-hash-table :test #'equalp)))
       (loop
 	 for poss being each hash-key of (gethash "tcbs" ht)
 	 using (hash-value tcb)
@@ -253,5 +255,5 @@
 	 and side-a = (read-tcb-side (gethash 1 tcb))
 	 and side-b = (read-tcb-side (gethash 2 tcb))
 	 for tcbobj = (make-tcb :pos pos :side-a side-a :side-b side-b)
-	 do (vector-push-extend tcbobj tcbs))
-      tcbs)))
+	 do (setf (gethash pos tcbs) tcbobj))
+      (make-ildb :tcbs tcbs))))

server-wrapper.lisp

@@ -1,10 +1,13 @@
 (defpackage :ywatds-server-wrapper
   (:use :cl)
   (:nicknames :ywsw)
-  (:export :toxml :wrap-html
-	   :safe-text-route :safe-json-route))
+  (:export :toxml :wrap-html :defsafe
+	   :safe-text-route :safe-json-route :safe-graphviz-route))
 (in-package :ywsw)
 
+(defmacro with-content-type (ctype &body body)
+  `(progn (setf (hunchentoot:content-type*) ,ctype) ,@body))
+
 (defun toxml (l)
   (cond
     ((null l) "")
@@ -40,6 +43,9 @@
 	 (hunchentoot:log-message* :error (format nil "~a" ,c))
 	 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)
   (alexandria:with-gensyms (docroute)
     (let ((lowername (string-downcase (string name)))
@@ -48,7 +54,7 @@
 		 (if (listp options) (car options) options)
 		 "</b><i>\\1</i><b>")))
       `(progn
-	 (easy-routes:defroute
+	 (defsafe
 	     ,docroute ,(format nil "/doc/http_~a" lowername) ()
 	     (wrap-html
 	      ,(format nil "API ~a" lowername)
@@ -70,8 +76,7 @@
 
 (defmacro safe-text-route (name options params doc &body body)
   (let ((response (gensym)))
-    `(with-documentation
-	 (,name ,options ,params ,doc)
+    `(with-documentation (,name ,options ,params ,doc)
        (easy-routes:defroute
 	   ,name ,options ,params
 	   (setf (hunchentoot:content-type*) "text/plain")
@@ -80,10 +85,18 @@
 
 (defmacro safe-json-route (name options params doc &body body)
   (alexandria:with-gensyms (response)
-    `(with-documentation
-	 (,name ,options ,params ,doc)
+    `(with-documentation (,name ,options ,params ,doc)
        (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"))))))
+
+(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) ""))))))

ywatds.asd

@@ -7,6 +7,7 @@
     :depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria" "cl-json")
     :serial t
     :components ((:file "helpers")
+		 (:file "graphviz")
 		 (:file "serialize-lib")
 		 (:file "interlocking")
 		 (:file "server-wrapper")