diff --git a/dataserver.lisp b/dataserver.lisp
index ce3ae2f..97a53ee 100644
--- a/dataserver.lisp
+++ b/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))
diff --git a/graphviz.lisp b/graphviz.lisp
new file mode 100644
index 0000000..e07533c
--- /dev/null
+++ b/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)))
diff --git a/interlocking.lisp b/interlocking.lisp
index e9d9789..ab64129 100644
--- a/interlocking.lisp
+++ b/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))))
diff --git a/server-wrapper.lisp b/server-wrapper.lisp
index db0b1b1..d7d65b3 100644
--- a/server-wrapper.lisp
+++ b/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)
"\\1")))
`(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) ""))))))
diff --git a/ywatds.asd b/ywatds.asd
index c00da74..4d92d21 100644
--- a/ywatds.asd
+++ b/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")