From imattsson at common-lisp.net Thu Nov 6 15:24:51 2008 From: imattsson at common-lisp.net (imattsson) Date: Thu, 06 Nov 2008 15:24:51 +0000 Subject: [noctool-cvs] CVS source/test-files Message-ID: Update of /project/noctool/cvsroot/source/test-files In directory cl-net:/tmp/cvs-serv17908 Added Files: net-test-1.cfg net-test-2.cfg Log Message: IM Added two test files, as examples of noctool peer config. --- /project/noctool/cvsroot/source/test-files/net-test-1.cfg 2008/11/06 15:24:51 NONE +++ /project/noctool/cvsroot/source/test-files/net-test-1.cfg 2008/11/06 15:24:51 1.1 (local-password "abcdefgh") (local-hostname "warez.bofh.se") (peer "localhost" "hgfedcba" "abcdefgh" 12543) --- /project/noctool/cvsroot/source/test-files/net-test-2.cfg 2008/11/06 15:24:51 NONE +++ /project/noctool/cvsroot/source/test-files/net-test-2.cfg 2008/11/06 15:24:51 1.1 (local-password "hgfedcba") (local-hostname "localhost") (peer "warez.bofh.se" "abcdefgh") From jprewett at common-lisp.net Mon Nov 10 14:29:45 2008 From: jprewett at common-lisp.net (jprewett) Date: Mon, 10 Nov 2008 14:29:45 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv11639 Modified Files: scheduler.lisp Log Message: tried to make multithreading stuff work better XXX CHECK ME XXX --- /project/noctool/cvsroot/source/scheduler.lisp 2008/08/26 15:54:29 1.7 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 14:29:45 1.8 @@ -2,27 +2,26 @@ (defvar *default-scheduler* nil) (defvar *network-updates-needed* nil) -(defvar *scheduler-loop-control* nil "Set to NIL to terminate a running scheduler loop") (defclass event () ((time :reader time :initarg :time) - (object :reader object :initarg :object) - )) + (object :reader object :initarg :object))) (defclass timeslot () ((time :reader time :initarg :time) (events :accessor events :initarg :events :initform nil) (next :accessor next :initarg :next :initform nil) - (prev :accessor prev :initarg :prev :initform nil) + (prev :accessor prev :initarg :prev :initform nil) + (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock")) )) (defclass scheduler () ((first-timeslot :accessor first-timeslot :initarg :first-timeslot) (last-timeslot :accessor last-timeslot :initarg :last-timeslot) + (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock")) ) (:default-initargs :first-timeslot nil :last-timeslot nil)) - (defmethod time ((foo null)) foo) (defmethod first-timeslot ((foo null)) @@ -35,8 +34,16 @@ (defmethod next ((foo null)) foo) +;;; XXX assumes a slot named "lock" in the object :P +;;; D'OH! +(defmacro with-object-lock (scheduler &body body) + (let ((lock (gensym))) + `(let ((,lock (lock ,scheduler))) + (sb-thread:with-mutex (,lock) + , at body)))) + (defun find-timeslot (scheduler time) - (cond ((null (first-timeslot scheduler)) + (cond ((null (first-timeslot scheduler)) (let ((new (make-instance 'timeslot :time time))) (setf (first-timeslot scheduler) new) (setf (last-timeslot scheduler) new) @@ -87,73 +94,124 @@ (setf (next here) new) (setf (prev next) new) (return new))))))))))) - (defgeneric add-event (event store)) (defgeneric process (thing)) (defmethod add-event ((event event) (store scheduler)) - (let ((time (time event))) - (let ((slot (find-timeslot store time))) - (add-event event slot)))) + (with-object-lock store + (let ((time (time event))) + (let ((slot (find-timeslot store time))) + (add-event event slot))))) (defmethod add-event ((event event) (store timeslot)) - (when (= (time event) (time store)) - (push event (events store)))) + (with-object-lock store + (when (= (time event) (time store)) + (push event (events store))))) (defun remove-timeslot (timeslot) - (setf (prev (next timeslot)) (prev timeslot)) - (setf (next (prev timeslot)) (next timeslot)) - (setf (prev timeslot) nil) - (setf (next timeslot) nil)) + (when timeslot + (with-object-lock timeslot + (progn + (setf (prev (next timeslot)) (prev timeslot)) + (setf (next (prev timeslot)) (next timeslot)) + (setf (prev timeslot) nil) + (setf (next timeslot) nil))))) (defun next-timeslot (&optional (scheduler *default-scheduler*)) - (unless scheduler - (unless *default-scheduler* - (setf *default-scheduler* (make-instance 'scheduler))) - (setf scheduler *default-scheduler*)) - (prog1 - (first-timeslot scheduler) - (setf (first-timeslot scheduler) (next (first-timeslot scheduler))) - (unless (null (first-timeslot scheduler)) - (setf (prev (first-timeslot scheduler)) nil)) - (when (null (first-timeslot scheduler)) - (setf (last-timeslot scheduler) nil)))) + (with-object-lock (if scheduler + scheduler + (or *default-scheduler* + (setf *default-scheduler* + (make-instance 'scheduler)))) + (prog1 + (first-timeslot scheduler) + (setf (first-timeslot scheduler) (next (first-timeslot scheduler))) + (unless (null (first-timeslot scheduler)) + (setf (prev (first-timeslot scheduler)) nil)) + (when (null (first-timeslot scheduler)) + (setf (last-timeslot scheduler) nil))))) (defun next-time (&optional (scheduler *default-scheduler*)) (when scheduler (time (first-timeslot scheduler)))) (defun schedule (object time &optional (scheduler *default-scheduler*)) - (let ((event (make-instance 'event :time time :object object))) - (when (null scheduler) - (setf *default-scheduler* (make-instance 'scheduler)) - (setf scheduler *default-scheduler*)) - - (add-event event scheduler))) + (let ((event (make-instance 'event :time time :object object))) + (when (null scheduler) + (setf *default-scheduler* (make-instance 'scheduler)) + (setf scheduler *default-scheduler*)) + (add-event event scheduler))) (defmethod process ((slot timeslot)) (loop for event in (events slot) - do (process event))) + do (process event))) +(defvar *process-mutex* (sb-thread:make-mutex :name "process lock")) + +(defvar *total-processes* + #+darwin 1 + #-darwin 32) + +(defvar *available-processes* + (loop for i from 1 to *total-processes* + collect + (sb-thread:make-mutex))) + +(defvar *mini-sleep* 0.05) + +;; XXX is this right? XXX +(defmacro noc-thread (&body body) + (let ((my-mutex (gensym)) + (first-mutex (gensym)) + (return-val (gensym))) + `(let ((,return-val NIL) + (,my-mutex + (sb-thread:with-mutex (*process-mutex*) + (loop as ,first-mutex = (car *available-processes*) + until ,first-mutex + do + (format t "+") + (sleep *mini-sleep*) + finally + (progn + (setf *available-processes* (cdr *available-processes*)) + (return ,first-mutex)))))) + (sb-thread:with-mutex (,my-mutex) + (setf ,return-val , at body)) + (sb-thread:with-mutex (*process-mutex*) + (setf *available-processes* (cons ,my-mutex *available-processes*))) + ,return-val))) (defmethod process ((event event)) #-no-noctool-threads - (sb-thread:make-thread (lambda () (process (object event)))) + (noc-thread + (sb-thread:make-thread + #'(lambda () + (handler-case + (sb-ext:with-timeout 3000 + (process (object event))) + (sb-ext::timeout () + (warn "Timing out thread ~A~%" sb-thread:*current-thread*)))))) #+no-noctool-threads (process (object event))) (defmethod process :before ((event net.hexapodia.noctool-scheduler:event)) (let ((obj (net.hexapodia.noctool-scheduler::object event))) - (when (or (noctool::proxies (noctool::equipment obj)) - (noctool::proxies obj)) + (when (or (noctool::proxies (noctool::equipment obj)) (noctool:proxies obj)) (push obj *network-updates-needed*)))) +(define-symbol-macro threads (sb-thread:list-all-threads)) + +(defvar *scheduler-loop-control* nil "Set to NIL to terminate a running scheduler loop") + (defun scheduler-loop () (setf *scheduler-loop-control* t) - (loop while *scheduler-loop-control* - do (let ((next (next-time))) - (cond ((null next) (sleep 60)) - ((<= next (get-universal-time)) (process (next-timeslot))) - (t (sleep (min 1 (- next (get-universal-time)))) - (process (next-timeslot))))))) + (loop while *scheduler-loop-control* + do (let ((next (next-time))) + (cond ((null next) (sleep 60)) + ((<= next (get-universal-time)) + (process (next-timeslot))) + (t (sleep (min 1 (- next (get-universal-time)))) + (process (next-timeslot))))))) + From jprewett at common-lisp.net Mon Nov 10 16:44:58 2008 From: jprewett at common-lisp.net (jprewett) Date: Mon, 10 Nov 2008 16:44:58 +0000 Subject: [noctool-cvs] CVS source Message-ID: 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)))))) From imattsson at common-lisp.net Mon Nov 10 18:59:53 2008 From: imattsson at common-lisp.net (imattsson) Date: Mon, 10 Nov 2008 18:59:53 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv14228 Modified Files: scheduler.lisp Log Message: IM Checked in what SHOULD be a better way of guarding the number of simultaneous processes, using SBCL semaphores to do the counting. This way there should be next-to-no risk losing what we're trying to do, with a slight downside of not having proper return values from the macro (not, I believe, that they're actually used). To change number of processes run-time, er... dunno (maybe SB-THREAD:SIGNAL-SEMAPHORE with a "high" number?). --- /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 14:29:45 1.8 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 18:59:53 1.9 @@ -153,6 +153,9 @@ #+darwin 1 #-darwin 32) +(defvar *process-semaphore* (sb-thread:make-semaphore :name "Simultaneous processes" :count *total-processes*)) + + (defvar *available-processes* (loop for i from 1 to *total-processes* collect @@ -161,6 +164,8 @@ (defvar *mini-sleep* 0.05) ;; XXX is this right? XXX +;; Looks needlessly complex, to me. +#-(and) (defmacro noc-thread (&body body) (let ((my-mutex (gensym)) (first-mutex (gensym)) @@ -183,6 +188,17 @@ (setf *available-processes* (cons ,my-mutex *available-processes*))) ,return-val))) +(defmacro with-semaphore (semaphore &body body) + `(progn + (sb-thread:wait-on-semaphore ,semaphore) + (unwind-protect + (progn , at body) + (sb-thread:signal-semaphore ,semaphore)))) + +(defmacro noc-thread (&body body) + `(with-semaphore *process-semaphore* + , at body)) + (defmethod process ((event event)) #-no-noctool-threads (noc-thread From imattsson at common-lisp.net Mon Nov 10 19:07:12 2008 From: imattsson at common-lisp.net (imattsson) Date: Mon, 10 Nov 2008 19:07:12 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv19953 Modified Files: scheduler.lisp Log Message: IM Must Make Sure to MP-protect the part we actually care about MP-protecting (that is, the call to PROCESS rather than the making of threads). --- /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 18:59:53 1.9 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 19:07:10 1.10 @@ -201,12 +201,11 @@ (defmethod process ((event event)) #-no-noctool-threads - (noc-thread (sb-thread:make-thread #'(lambda () (handler-case (sb-ext:with-timeout 3000 - (process (object event))) + (noc-thread (process (object event))) (sb-ext::timeout () (warn "Timing out thread ~A~%" sb-thread:*current-thread*)))))) #+no-noctool-threads From jprewett at common-lisp.net Mon Nov 10 19:52:36 2008 From: jprewett at common-lisp.net (jprewett) Date: Mon, 10 Nov 2008 19:52:36 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv3569 Modified Files: scheduler.lisp Log Message: removed cruft --- /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 19:07:10 1.10 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 19:51:54 1.11 @@ -155,39 +155,6 @@ (defvar *process-semaphore* (sb-thread:make-semaphore :name "Simultaneous processes" :count *total-processes*)) - -(defvar *available-processes* - (loop for i from 1 to *total-processes* - collect - (sb-thread:make-mutex))) - -(defvar *mini-sleep* 0.05) - -;; XXX is this right? XXX -;; Looks needlessly complex, to me. -#-(and) -(defmacro noc-thread (&body body) - (let ((my-mutex (gensym)) - (first-mutex (gensym)) - (return-val (gensym))) - `(let ((,return-val NIL) - (,my-mutex - (sb-thread:with-mutex (*process-mutex*) - (loop as ,first-mutex = (car *available-processes*) - until ,first-mutex - do - (format t "+") - (sleep *mini-sleep*) - finally - (progn - (setf *available-processes* (cdr *available-processes*)) - (return ,first-mutex)))))) - (sb-thread:with-mutex (,my-mutex) - (setf ,return-val , at body)) - (sb-thread:with-mutex (*process-mutex*) - (setf *available-processes* (cons ,my-mutex *available-processes*))) - ,return-val))) - (defmacro with-semaphore (semaphore &body body) `(progn (sb-thread:wait-on-semaphore ,semaphore) From imattsson at common-lisp.net Wed Nov 12 17:56:28 2008 From: imattsson at common-lisp.net (imattsson) Date: Wed, 12 Nov 2008 17:56:28 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv30892 Modified Files: scheduler.lisp Log Message: IM Ooooops! Too quick with the sexp-surgery. PROCESS (event) should hopefully work better now. --- /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 19:51:54 1.11 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/12 17:56:28 1.12 @@ -172,9 +172,9 @@ #'(lambda () (handler-case (sb-ext:with-timeout 3000 - (noc-thread (process (object event))) + (noc-thread (process (object event)))) (sb-ext::timeout () - (warn "Timing out thread ~A~%" sb-thread:*current-thread*)))))) + (warn "Timing out thread ~A~%" sb-thread:*current-thread*))))) #+no-noctool-threads (process (object event))) From jprewett at common-lisp.net Wed Nov 12 21:56:25 2008 From: jprewett at common-lisp.net (jprewett) Date: Wed, 12 Nov 2008 21:56:25 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv18109 Modified Files: tests.lisp Log Message: ERRORS? ERRORS? We don't >>NEED<< no stinking errors! added without-errors macro to discard any error conditions wrapped just about everything in it moved rescheduling monitors into an around method global to all monitors --- /project/noctool/cvsroot/source/tests.lisp 2008/08/29 17:29:45 1.8 +++ /project/noctool/cvsroot/source/tests.lisp 2008/11/12 21:56:24 1.9 @@ -1,34 +1,40 @@ (in-package #:net.hexapodia.noctool) -(defmethod process :around ((monitor monitor)) - (if (host-pings monitor) - (call-next-method) - (schedule monitor (+ (get-universal-time) (interval monitor))))) +;; OK, this is *awesome* programming form, but... +(defmacro without-errors (error-form &body body) + `(handler-case , at body + (t (c) (progn + (warn "ignoring condition: ~A" c) + ,error-form)))) -(defmethod process :around ((monitor ping-monitor)) - (call-next-method)) +(defmethod process :around ((monitor monitor)) + (unwind-protect + (if (host-pings monitor) + (call-next-method)) + (let ((now (get-universal-time))) + (setf (last-updated monitor) now) + (schedule monitor + (+ now + (* + (interval monitor) + (if (>= (alert-level monitor) *alerting*) 5 1)))) + (format t "just rescheduled monitor: ~A~%" monitor)))) (defmethod process ((monitor ping-monitor)) - (let ((kit (equipment monitor))) - (let ((data (make-ping (name kit)))) - (let ((failed (count -1.0 data :test #'=)) - (over-rtt (count (max-rtt monitor) data :test #'<))) - (setf (alert-level monitor) - (decay-alert (alert-level monitor) - (+ (if (>= failed (max-fail monitor)) - *alerting* - 0) - (* 10 failed) - (* 5 over-rtt)))) - (when (graph monitor) - (add-value (graph monitor) (reduce #'max data))) - (let ((now (get-universal-time))) - (setf (last-updated monitor) now) - (schedule monitor - (+ now - (* - (interval monitor) - (if (>= (alert-level monitor) *alerting*) 5 1))))))))) + (without-errors NIL + (let ((kit (equipment monitor))) + (let ((data (make-ping (name kit)))) + (let ((failed (count -1.0 data :test #'=)) + (over-rtt (count (max-rtt monitor) data :test #'<))) + (setf (alert-level monitor) + (decay-alert (alert-level monitor) + (+ (if (>= failed (max-fail monitor)) + *alerting* + 0) + (* 10 failed) + (* 5 over-rtt)))) + (when (graph monitor) + (add-value (graph monitor) (reduce #'max data)))))))) (defgeneric process-disk (monitor host)) (defgeneric process-df (host pty)) @@ -67,10 +73,12 @@ (defmethod process-df (host pty) (declare (ignore host)) - (parse-df pty)) + (without-errors NIL + (parse-df pty))) (defmethod process-disk ((monitor disk-container) (host linux-host)) - (with-pty (pty (make-ssh-command "df" (address host) (username host))) + (without-errors NIL + (with-pty (pty (make-ssh-command "df" (address host) (username host))) ;; Process disk block usage (loop for split in (parse-df pty) do @@ -100,6 +108,7 @@ (setf (mountpoint platter) mount) (setf (disk-free platter) free) (add-value (disk-graph platter) used) + (setf (last-updated platter) (get-universal-time)) (let ((percent (if (= 0 disk) 100 (* 100 (/ used disk))))) (setf (alert-level platter) (decay-alert @@ -109,38 +118,32 @@ ((<= (* 0.9 (disk-percent platter)) percent) *warning*) - (t 0))))))))))))) + (t 0)))))))))))))) (defmethod process ((monitor disk-container)) - (process-disk monitor (equipment monitor)) - (let ((now (get-universal-time))) - (setf (last-updated monitor) now) - (schedule monitor (+ now - (interval monitor)))) - ) + (without-errors NIL + (process-disk monitor (equipment monitor)))) (defmethod process ((monitor load-monitor)) - (with-pty (pty (make-ssh-command "uptime" (address (equipment monitor)) (username (equipment monitor)))) - (let ((data (split-line (string-trim '(#\Space #\Return #\Newline) - (read-line pty))))) - (let ((loads (cdr (member "average" data :test #'search)))) - (let ((now-load (read-from-string (nth 0 loads)))) - (let ((new-alert - (cond ((< now-load (low-water monitor)) 0) - ((<= (low-water monitor) now-load (high-water monitor)) - (+ *warning* (* (- now-load (low-water monitor)) - (/ (- *alerting* *warning*) - (- (high-water monitor) - (low-water monitor)))))) - (t *alerting*)))) - (setf (alert-level monitor) (decay-alert (alert-level monitor) - (round new-alert)))) - (add-value (graph-1 monitor) now-load) - (add-value (graph-5 monitor) (read-from-string (nth 1 loads))) - (add-value (graph-10 monitor) (read-from-string (nth 2 loads))))))) - (schedule monitor - (+ (get-universal-time) - (interval monitor)))) + (without-errors NIL + (with-pty (pty (make-ssh-command "uptime" (address (equipment monitor)) (username (equipment monitor)))) + (let ((data (split-line (string-trim '(#\Space #\Return #\Newline) + (read-line pty))))) + (let ((loads (cdr (member "average" data :test #'search)))) + (let ((now-load (read-from-string (or (nth 0 loads) "-1")))) + (let ((new-alert + (cond ((< now-load (low-water monitor)) 0) + ((<= (low-water monitor) now-load (high-water monitor)) + (+ *warning* (* (- now-load (low-water monitor)) + (/ (- *alerting* *warning*) + (- (high-water monitor) + (low-water monitor)))))) + (t *alerting*)))) + (setf (alert-level monitor) (decay-alert (alert-level monitor) + (round new-alert)))) + (add-value (graph-1 monitor) now-load) + (add-value (graph-5 monitor) (read-from-string (or (nth 1 loads) "-1"))) + (add-value (graph-10 monitor) (read-from-string (or (nth 2 loads) "-1"))))))))) (defmethod process ((monitor tcp-monitor)) (when (and (sent-data monitor) From jprewett at common-lisp.net Wed Nov 26 14:24:27 2008 From: jprewett at common-lisp.net (jprewett) Date: Wed, 26 Nov 2008 14:24:27 +0000 Subject: [noctool-cvs] CVS source Message-ID: Update of /project/noctool/cvsroot/source In directory cl-net:/tmp/cvs-serv4214 Added Files: noctool.css Log Message: css file for Web UI --- /project/noctool/cvsroot/source/noctool.css 2008/11/26 14:24:27 NONE +++ /project/noctool/cvsroot/source/noctool.css 2008/11/26 14:24:27 1.1 body {background-color: darkcyan; color: DarkBlue} .warning {color: orange} .alerting {color: red; background-color: orange} .normal {color: green} div {width: auto} div.monitor-box {width: 225px;} div.hostname {color: black} div.hostbox {background-color: DeepSkyBlue; width: 225px;} div.graph-display-box{position: relative;} span.timestamp{color: black; position: absolute; bottom: 5px; right: 5px;} span.image-label{color: black; position: relative; top: 0px; } div.graph-image{position: relative; bottom: 0px;} div.last-updated{color: black} img {border: 5px groove grey} div.root{position: relative} div.zoom{background: black; color: lime; float: left; float: top;} div.systems{float: left;} div.hide{display: none;}