[noctool-cvs] CVS source
jprewett
jprewett at common-lisp.net
Mon Nov 10 16:44:58 UTC 2008
Update of /project/noctool/cvsroot/source
In directory cl-net:/tmp/cvs-serv8654
Added Files:
web.lisp
Log Message:
FINALLY, adding web.lisp
- not done, by any means!
--- /project/noctool/cvsroot/source/web.lisp 2008/11/10 16:44:58 NONE
+++ /project/noctool/cvsroot/source/web.lisp 2008/11/10 16:44:58 1.1
(in-package :sw)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :hunchentoot)
(require :cl-who)
(require :symbolicweb)
(use-package :hunchentoot)
(use-package :cl-who)
(use-package :symbolicweb))
(setf *SHOW-LISP-BACKTRACES-P* t)
(setf *SHOW-LISP-ERRORS-P* t)
(setf CHUNGA:*ACCEPT-BOGUS-EOLS* t)
;; turn off SW debugging
(setf *sw-debug* NIL)
;; with-gensyms is modified from Paul Graham On Lisp
(defmacro with-gensyms (symbols &body body)
"Binds a whole list of variables to gensyms. If the variables are lists, then the car is the symbol and the cadr is the string to use for the gensym."
`(let ,(mapcar #'(lambda (symbol) (if (listp symbol)
`(,(car symbol) (gensym ,(cadr symbol)))
`(,symbol (gensym))))
symbols)
, at body))
(defwidget monitor (container)
((monitor :accessor monitor :initarg :monitor :initform (error "monitor must be supplied"))))
(defmethod initialize-instance :AFTER ((monitor monitor) &key)
(add-to monitor
(mk-span (symbol-name (class-name (class-of (monitor monitor)))))))
(defvar *noc-host-hash* (make-hash-table))
(defwidget noc-host (container)
((noc-host :accessor noc-host :initarg :noc-host :initform (error "noc-host must be supplied"))))
(defmethod initialize-instance :AFTER ((noc-host noc-host) &key)
(add-to noc-host
(mk-span (noctool::name (noc-host noc-host)))))
(defmacro defensure (name widget-form hash &body body)
`(defmacro ,name (instance )
(with-gensyms ((val "VAL")
(foundp "FOUNDP")
(the-widget-form "WIDGET-FORM"))
` (multiple-value-bind (,val ,foundp)
(gethash ,instance ,,hash)
(if ,foundp
,val
(progn
(let* ((instance ,instance)
(widget ,',widget-form))
,@',body
(setf (gethash ,instance ,,hash) widget))))))))
;; XXX do I need all of these damn hashes???
(defvar *monitor-hash* (make-hash-table))
(defvar *last-updated-hash* (make-hash-table))
(defvar *last-rtt-hash* (make-hash-table))
(defvar *last-load-hash* (make-hash-table))
(defvar *disk-widget-hash* (make-hash-table))
(defvar *load-1-hash* (make-hash-table))
(defvar *load-5-hash* (make-hash-table))
(defvar *load-10-hash* (make-hash-table))
(defmacro ensure-load (name graph-slot hash)
(with-gensyms ((graph "GRAPH") (span "SPAN"))
`(defensure ,name
(let* ((,graph (slot-value instance ',graph-slot))
(,span (mk-span
(format NIL "~2$"
(aref (noctool-graphs::short ,graph)
(mod
(1- (noctool-graphs::short-ix ,graph))
300))))))
,span)
,hash
(defmethod noctool::add-value
:after ((graph (eql (slot-value instance ',graph-slot))) value)
(setf (html-of widget)
(format NIL
"~2$"
(aref (noctool-graphs::short graph)
(mod (1- (noctool-graphs::short-ix graph)) 300))))))))
(ensure-load ensure-load-1 noctool::graph-1 *load-1-hash*)
(ensure-load ensure-load-5 noctool::graph-5 *load-5-hash*)
(ensure-load ensure-load-10 noctool::graph-10 *load-10-hash*)
(defwidget load-widget (container)
((monitor :initform (error "monitor must be supplied")
:initarg :monitor :accessor monitor)
(load-1 :accessor load-1)
(load-5 :accessor load-5)
(load-10 :accessor load-10)))
(defmethod initialize-instance :after ((widget load-widget) &key)
(let ((space (mk-span " "))
(load (mk-span "Load:")))
(with-slots (monitor load-1 load-5 load-10) widget
(setf load-1 (ensure-load-1 monitor)
load-5 (ensure-load-5 monitor)
load-10 (ensure-load-10 monitor))
(add-to widget load (mk-span " ") load-1 (mk-span " ") load-5 (mk-span " ") load-10))))
(defensure ensure-monitor-widget (make-instance 'monitor :monitor instance) *monitor-hash*
(defmethod (setf noctool::alert-level) :after (new (instance (eql instance)))
(setf (css-class-of widget)
(alert-class (noctool::alert-level instance)))))
(defensure ensure-last-updated-widget
(mk-span (sb-int:format-universal-time NIL (noctool::last-updated instance)))
*last-updated-hash*
(defmethod (setf noctool::last-updated) :after (new (instance (eql instance)))
(setf (html-of widget)
(sb-int:format-universal-time NIL new))))
(defensure ensure-last-rtt
(mk-span
(let ((idx (noctool-graphs::short-ix (noctool::graph instance))))
(format NIL "~A seconds"
(aref (noctool-graphs::short (noctool::graph instance))
(mod (1- idx) 300)))))
*last-rtt-hash*
(defmethod noctool::add-value :after ((graph (eql (noctool::graph instance))) value)
(setf (html-of widget)
(format NIL "~A seconds"
(aref (noctool-graphs::short
graph)
(mod (1- (noctool-graphs::short-ix graph)) 300))))))
(defensure ensure-last-load
(make-instance 'load-widget :monitor instance)
*last-load-hash*
())
(defensure ensure-noc-host-widget
(make-instance 'noc-host :noc-host instance) *noc-host-hash*
(defmethod (setf noctool::alert-level)
:after (new-val (host (eql instance)))
(setf (css-class-of widget)
(alert-class (noctool::alert-level instance)))))
(defensure ensure-disk-widget
(let ((widget (mk-span (escape-for-html (noctool::device instance)))))
(setf (css-class-of widget) (alert-class (noctool::alert-level instance)))
widget)
*disk-widget-hash*
(defmethod (setf noctool::alert-level)
:after (new-val (host (eql instance)))
(setf (css-class-of widget)
(alert-class (noctool::alert-level instance)))))
(defmacro toggle (thing on-expr off-expr &key (default :on))
(let ((v (gensym)))
`(let ((,v (eq ,default :on)))
(iambda
(if (setf ,v (not ,v))
,on-expr
,off-expr)))))
(defmacro h/s (thing &key (hide "hide") (normal "normal"))
`(toggle ,thing
(setf (css-class-of ,thing) ,normal)
(setf (css-class-of ,thing) ,hide) :default :off))
(defmethod alert-class ((i number))
(cond ((>= i noctool::*alerting*)
"alerting")
((>= i noctool::*warning*)
"warning")
(t
"normal")))
;; put this somewhere else! XXX
(defmethod noctool-scheduler:process :after ((monitor noctool::monitor))
(setf (noctool:last-updated monitor) (get-universal-time))
(format t "just processed monitor: ~A for equipment: ~A~%"
monitor
(noctool::name (noctool::equipment monitor))))
(defmethod noctool-scheduler:process :after ((slot noctool-scheduler::timeslot))
(format t "just processed timeslot: ~A~%" slot))
(defwidget eqp (container)
((system-name :initform NIL :initarg :system-name :accessor system-name)
(system :initform (error "system must be supplied") :initarg :system :accessor system)
(namebox :initform (mk-container NIL)
:accessor namebox)
(monitors :initform NIL :initarg :monitors :accessor monitors)
(monitorbox :initform (mk-container NIL)
:accessor monitorbox)))
(defmethod initialize-instance :AFTER ((eqp eqp) &key)
(with-slots (system namebox monitorbox) eqp
(let ((namelink (mk-link (ensure-noc-host-widget system))))
(add-to namebox namelink)
(add-to eqp namebox)
(setf (css-class-of monitorbox) "hide")
(setf (on-click-of namelink)
(h/s monitorbox))
(add-to eqp monitorbox)
(loop for mon in (noctool::monitors system) do
(let ((link (mk-link (ensure-monitor-widget mon) :href "#"))
(mon2 mon))
(add-to monitorbox link)
(setf (on-click-of link)
(iambda
(if (eql (info-show *app*) mon2)
(progn
(remove-all (info-pane *app*))
(setf (info-show *app*) NIL))
(let ((info (display-monitor-info mon2)))
(remove-all (info-pane *app*))
(add-to (info-pane *app*) info)
(setf (info-show *app*) mon2))))))))))
(defmethod display-monitor-info (mon)
(mk-container
(list
(mk-div (noctool::name (noctool::equipment mon)))
(mk-span (symbol-name (class-name (class-of mon))))
(mk-span " Last Updated ")
(ensure-last-updated-widget mon))))
(defmethod display-monitor-info ((mon noctool::disk-container))
(mk-container
(nconc
(list
(mk-div (noctool::name (noctool::equipment mon)))
(mk-span (symbol-name (class-name (class-of mon))))
(mk-span " Last Updated ")
(ensure-last-updated-widget mon)
(mk-span (who (:br))))
(loop for disk in (noctool::disk-list mon)
nconc
(list
(ensure-disk-widget disk)
(mk-span (who (:br))))))))
(defmethod display-monitor-info ((mon noctool::ping-monitor))
(mk-container
(list
(mk-div (noctool::name (noctool::equipment mon)))
(mk-span (symbol-name (class-name (class-of mon))))
(mk-span " Last Updated ")
(ensure-last-updated-widget mon)
(mk-span (who (:br)))
(mk-span "last rtt: ")
(ensure-last-rtt mon)
(mk-span (who (:br))))))
(defmethod display-monitor-info ((mon noctool::load-monitor))
(mk-container
(list
(mk-div (noctool::name (noctool::equipment mon)))
(mk-span (symbol-name (class-name (class-of mon))))
(mk-span " Last Updated ")
(ensure-last-updated-widget mon)
(mk-span (who (:br)))
(ensure-last-load mon))))
(defapp noctool-app ()
((systems :accessor systems
;; :allocation :class
:initform (loop for eqp in noctool::*equipment*
collect
(make-instance 'eqp :system eqp)))
(systems-pane :accessor systems-pane :initform (mk-container NIL))
(info-show :accessor info-show :initform NIL)
(info-pane :accessor info-pane :initform (mk-container NIL))))
(defmethod initialize-instance :AFTER ((app noctool-app) &key)
(with-slots (systems-pane info-pane) app
(setf (css-class-of systems-pane) "systems")
(setf (css-class-of info-pane) "zoom")))
(set-uri 'noctool-app "/")
(defmethod render ((app noctool-app))
(who
(:html
(:head
(:title "Noctool")
(str (js-sw-headers app))
(:link :rel :stylesheet :type :text/css :href "/noctool.css"))
(:body
(str (sw-heading :title (string-downcase (princ-to-string (type-of app)))))
(:div :id "sw-root")
(:noscript "JavaScript needs to be enabled.")))))
(defmethod render-viewport ((viewport viewport) (app noctool-app))
(with-slots (systems systems-pane info-pane) app
(loop for eqp in systems
do
(add-to systems-pane eqp))
(add-to *root* systems-pane)
(add-to *root* info-pane)))
(push (hunchentoot::create-static-file-dispatcher-and-handler "/noctool.css" "/noctool/source/noctool.css" "text/css") (tbnl:server-dispatch-table (sw::ht-server-instance-of sw::*server*)))
(defun noctool-image-dispatch ()
())
;; XXX unimplemented!
(push (create-prefix-dispatcher "/images/" #'noctool-image-dispatch)
*dispatch-table*)
(defun schedule-all-monitors ()
(loop for equipment in noctool::*equipment*
do
(loop for mon in
(remove-if
(lambda (x)
(eql 'noctool::cpu-monitor (type-of x)))
(noctool::monitors equipment))
;; (remove-if
;; (lambda (x)
;; (not (eql 'load-monitor (type-of x))))
;; (noctool::monitors equipment))
do
(noctool::schedule mon (1+ (get-universal-time))))))
More information about the noctool-cvs
mailing list