From imattsson at common-lisp.net Thu Jul 3 07:30:24 2008 From: imattsson at common-lisp.net (imattsson) Date: Thu, 3 Jul 2008 03:30:24 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080703073024.DAD38751B3@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv14870 Modified Files: classes.lisp graphing.lisp network-globals.lisp network-utils.lisp network.lisp noctool.asd packages.lisp scheduler.lisp tests.lisp Log Message: IM Bulk update of (mostly) network-code-related changes. There's one change that pertains to graph code (setting the last-updated field). --- /project/noctool/cvsroot/source/classes.lisp 2008/06/20 12:19:57 1.9 +++ /project/noctool/cvsroot/source/classes.lisp 2008/07/03 07:30:23 1.10 @@ -246,3 +246,8 @@ (display-objects :accessor display-objects :initarg :display-objects) ) (:default-initargs :display-objects nil)) + +(defmethod process :before ((event net.hexapodia.noctool-scheduler:event)) + (let ((obj (net.hexapodia.noctool-scheduler::object event))) + (when (or (proxies (equipment obj)) (proxies obj)) + (push obj *network-updates-needed*)))) --- /project/noctool/cvsroot/source/graphing.lisp 2008/06/21 11:07:36 1.5 +++ /project/noctool/cvsroot/source/graphing.lisp 2008/07/03 07:30:24 1.6 @@ -112,7 +112,10 @@ (when (zerop (mod (short-ix graph) 12)) (add-medium graph)) (setf (aref (short graph) (short-ix graph)) value) - (bump-ix graph short-ix)) + (bump-ix graph short-ix) + (when (proxies graph) + (loop for proxy in (proxies graph) + do (noctool-network:graph-update proxy id (id graph) value)))) (defmethod add-medium ((graph meter-graph)) --- /project/noctool/cvsroot/source/network-globals.lisp 2008/06/15 10:45:25 1.1 +++ /project/noctool/cvsroot/source/network-globals.lisp 2008/07/03 07:30:24 1.2 @@ -10,4 +10,8 @@ (defvar *handler-map* (make-hash-table)) -(defvar *proxies* (make-hash-table)) +(defvar *proxies* (make-hash-table :test 'equal)) + +(defvar *reply-structure* (make-hash-table :test 'equal)) + +(declaim (ftype (function (peer id value)) update-graph)) --- /project/noctool/cvsroot/source/network-utils.lisp 2008/06/15 10:45:25 1.1 +++ /project/noctool/cvsroot/source/network-utils.lisp 2008/07/03 07:30:24 1.2 @@ -11,3 +11,8 @@ `(defun ,name (conn ,proto-sym , at llist) (declare (ignorable ,proto-sym)) , at body)) + +(defun pick (object sequence &key (test #'eql) (key #'identity)) + (loop for pos = (position object sequence :test test :key key) then (position object sequence :test test :key key :start (1+ pos)) + until (null pos) + collect (elt sequence pos))) --- /project/noctool/cvsroot/source/network.lisp 2008/06/15 10:45:23 1.3 +++ /project/noctool/cvsroot/source/network.lisp 2008/07/03 07:30:24 1.4 @@ -14,6 +14,12 @@ ) (:default-initargs :nest-depth 0 :state :initial)) +(defclass accept-event () + ()) + +(defclass peer-check-event () + ()) + (defun find-peer (name) (gethash name *peers*)) @@ -139,11 +145,8 @@ (defmethod send ((conn connection) format &rest args) (let ((stream (sock conn)) (peer (peer conn))) - (let ((msg (apply #'format nil format args)) - (hmac (ironclad:make-hmac (my-passwd peer) :sha1))) - (ironclad:update-hmac hmac (octetify msg)) - (format stream "(message ~a ~s)" msg - (encode-base64 (ironclad:hmac-digest hmac))) + (let ((msg (apply #'format nil format args))) + (format stream "(message ~a ~s)" msg (make-signature msg (my-passwd peer))) (finish-output stream)))) (defmethod send ((peer remote-node) format &rest args) @@ -195,17 +198,9 @@ (socket-close *incoming*)) (setf *incoming* (socket-listen address port)))) -;;; Not entirely sure HOW to write this one, at the moment. Could, I suspect, -;;; use threading. (defun check-accept (socket) - (loop until *stop-accept-loop* - do (let ((new (socket-accept socket))) - (push new *connections*))) - (setf *stop-accept-loop* nil)) - -(defun read-remotely () - (loop for conn in *connections* - do (handle-peer conn))) + (let ((new (socket-accept socket))) + (push (make-connection (socket-stream new)) *connections*))) (defun check-signature (conn message digest) (let ((peer (peer conn))) @@ -222,16 +217,16 @@ (defun send-proxy-list (conn objects) (let ((objdata (loop for object in objects collect (id object) - collect (list (class-of object)) + collect (list (class-name (class-of object))) collect (name object)))) (send conn "(class-list ~{(proxy-equipment (id ~a) (classes ~{~a~}) (name ~s))~})" objdata))) (defun send-proxy-equipment (conn obj) (let ((monitor-list (loop for mon in (monitors obj) collect (id mon) - collect (class-of mon) + collect (class-name (class-of mon)) collect (alert-level mon)))) - (send conn "(proxy-equipment (id ~a) (classes ~{~a~}) (name ~s) (monitors ~{(monitor (id ~a) (type ~a) (alert-level ~d))~}))" (id obj) (list (class-of obj)) (name obj) monitor-list))) + (send conn "(proxy-equipment (id ~a) (classes ~{~a~}) (name ~s) (monitors ~{(monitor (id ~a) (type ~a) (alert-level ~d))~}))" (id obj) (list (class-name (class-of obj))) (name obj) monitor-list))) (defun send-graph (conn graph) (send conn "(proxy-graph (id ~s) (type ~a) ~{#(~{~a~})~})" @@ -251,25 +246,53 @@ (find-class class-id))) (t (error "Unknown class")))))) -(defun get-proxy (id) - (gethash id *proxies*)) - -(defun (setf get-proxy) (new id) - (setf (gethash id *proxies*) new)) +(defun get-proxy (conn id) + (unless *proxies* + (setf *proxies* (make-hash-table :test 'equal))) + (gethash (cons conn id) *proxies*)) + +(defun (setf get-proxy) (new conn id) + (unless *proxies* + (setf *proxies* (make-hash-table :test 'equal))) + (setf (gethash (cons conn id) *proxies*) new)) (defun terminate-conn (conn) (setf (state conn) :terminated) (setf *connections* (delete conn *connections*))) (defhandler request-proxy-class (request-proxy-class class-name) - (let ((objects (get-class class-name))) - (send-proxy-list conn objects))) + (let ((class (get-class class-name))) + (let ((objects (loop for eq in *equipment* + if (eql (class-of eq) class) + collect eq))) + + (send-proxy-list conn objects)))) + +(defun make-proxy (peer kit) + (make-instance 'net.hexapodia.noctool::proxy :remote-node peer :object kit)) + (defhandler request-proxy-equipment (request-proxy-equipment eq-id) - (let ((equipment (find eq-id *equipment* :key #'id))) + (let ((equipment (noctool::get-instance-by-id (string eq-id)))) (when equipment + (push (make-proxy (peer conn) equipment) + (noctool::proxies equipment)) (send-proxy-equipment conn equipment)))) +(defun handle-monitor (conn monitor-spec object) + (when (eql (car monitor-spec) 'monitor) + (let ((id nil) + (type nil) + (alert-val nil)) + (loop for (op opval) in (cdr monitor-spec) + do (case op + (id (setf id opval)) + (type (setf type opval)) + (alert-level (setf alert-val opval)))) + (let ((mon (make-instance type :id id :alert-level alert-val))) + (push mon (monitors object)) + (setf (get-proxy conn id) mon))))) + (defhandler proxy-equipment (proxy-equipment &rest modifiers) (let ((classes nil) (monitors nil) @@ -280,19 +303,64 @@ (id (setf id (car opvals))) (classes (setf classes opvals)) (monitors (setf monitors opvals)) - (name (setf name (car opvals))))) - (let ((proxy (get-proxy id))) + (name (setf name (car opvals))))) + (let ((proxy (get-proxy conn id))) (let ((object (if proxy (object proxy) (make-instance (car classes) :id id :name name)))) (unless proxy - (let ((proxy (make-instance 'proxy - :remote-node (peer conn) - :object object))) - (setf (get-proxy id) proxy))) + (let ((proxy (make-proxy (peer conn) object))) + (setf (get-proxy conn id) proxy)) + ) (when (and monitors (null (monitors object))) - ;; Build monitor list and chuck it on the monitors-list - ))))) + (push object *equipment*) + (loop for mon in monitors + do (handle-monitor conn mon object))) + + (setf (gethash (cons (peer conn) :proxy-equipment) *reply-structure*) + object) + )))) + +(defhandler class-list (class-list &rest equipment-list) + (let ((data (loop for eq in equipment-list + collect (apply #'proxy-equipment conn eq)))) + (let ((peer (peer conn))) + (setf (gethash (cons peer :list-class) *reply-structure*) data)))) + +(defhandler handle-protocol-error (protocol-error) + (values :protocol-error conn)) + +(defhandler proxy-update (proxy-update &rest args) + (let ((id (cadr (assoc 'id args))) + (val (cadr (assoc 'alert-level args)))) + (let ((proxy (get-proxy conn id))) + (setf (alert-level (object proxy)) val)))) + +(defhandler graph-update-handler (graph-update id measure) + (unless (and (eql (car id) 'id) + (eql (car measure) 'measure)) + (protocol-error conn) + (error "Protocol error")) + (let ((id (cadr id)) + (measure (cadr measure))) + (let ((proxy (get-proxy conn id))) + (when proxy + (noctool-graphs:add-value (object proxy) measure))))) + +(defun delete-proxy (conn id) + (let ((proxy (get-proxy conn id))) + (when proxy + (let ((kit (object proxy))) + (setf (noctool:proxies kit) + (delete proxy (noctool:proxies kit))) + (setf (get-proxy conn id) nil))))) + +(defhandler delete-proxy-equipment (delete-proxy-equipment id) + (delete-proxy conn id)) + +(defhandler delete-proxy-graph (delete-proxy-graph id) + (delete-proxy conn id)) + (defun handle-peer (conn) (let ((msg (handle-read conn))) @@ -335,3 +403,29 @@ (t (protocol-error conn)))) ))) (error () (protocol-error conn))))))) + + +(defun read-remotely () + (loop for conn in *connections* + do (handle-peer conn))) + +(defmethod noctool-scheduler:process ((event accept-event)) + (check-accept *incoming*) + (schedule event (1+ (get-universal-time)))) + +(defmethod noctool-scheduler:process ((event peer-check-event)) + (loop for conn in *connections* + do (handle-read conn)) + (schedule event (1+ (get-universal-time)))) + +(defun update-peers (monitor-list) + (loop for mon in monitor-list + do (let ((update (format nil "(proxy-update (id ~a) (alert-level ~a))" + (id mon) (alert-level mon)))) + (loop for proxy in (noctool::proxies (noctool::equipment mon)) + do (send (remote-node proxy) "~a" update))))) + +(defmethod noctool-scheduler:process :before ((slot noctool-scheduler::timeslot)) + (let ((tmp nil)) + (shiftf tmp *network-updates-needed* nil) + (sb-thread:make-thread (lambda () (update-peers tmp))))) --- /project/noctool/cvsroot/source/noctool.asd 2008/06/14 16:18:04 1.5 +++ /project/noctool/cvsroot/source/noctool.asd 2008/07/03 07:30:24 1.6 @@ -6,16 +6,20 @@ :version "0.1" :depends-on (:usocket :cl-ppcre :ironclad :image) :components ((:file "packages") + (:file "scheduler" :depends-on ("packages")) + (:file "network-globals" :depends-on ("packages")) (:file "globals" :depends-on ("packages")) (:file "generics" :depends-on ("packages" "globals")) (:file "classes" :depends-on ("packages" "globals" "graphing" "graph-utils")) (:file "methods" :depends-on ("packages" "classes" "generics")) - (:file "graphing" :depends-on ("packages")) + (:file "graphing" :depends-on ("packages" "network-globals")) (:file "graph-utils" :depends-on ("packages" "graphing")) (:file "graph-monitors" :depends-on ("packages" "classes")) (:file "config" :depends-on ("utils" "packages" "classes" "globals" "generics")) (:file "utils" :depends-on ("packages" "scheduler")) - (:file "scheduler" :depends-on ("packages")) (:file "tests" :depends-on ("packages" "graph-utils" "globals" "classes" "utils" "scheduler")) - (:file "default-settings" :depends-on ("packages" "globals"))) - ) + (:file "default-settings" :depends-on ("packages" "globals")) + (:file "network-utils" :depends-on ("packages" "network-globals")) + (:file "network" :depends-on ("scheduler" "packages" "network-utils" "network-globals")) + (:file "network-remote-calls" :depends-on ("packages" "network-globals" "network")) + )) --- /project/noctool/cvsroot/source/packages.lisp 2008/06/15 10:45:25 1.8 +++ /project/noctool/cvsroot/source/packages.lisp 2008/07/03 07:30:24 1.9 @@ -4,7 +4,7 @@ (:nicknames #:noctool-scheduler) (:use #:cl) (:shadow #:time) - (:export #:schedule #:next-timeslot #:events #:process #:next-time)) + (:export #:schedule #:next-timeslot #:events #:process #:next-time #:*network-updates-needed* #:event)) (defpackage #:net.hexapodia.noctool-graphs (:nicknames #:noctool-graphs) @@ -17,7 +17,7 @@ (:use #:cl #:usocket #:net.hexapodia.noctool-scheduler #:net.hexapodia.noctool-graphs #+sbcl :sb-mop) (:export - #:*proxies* #:*peers* #:*equipment* #:*views* #:*noctool-package* #:id #:last-updated #:unix-host #:linux-host #:cpu-monitor #:load-monitor #:ping-monitor #:remote-node #:decode-base64 #:encode-base64 #:octetify #:destination #:alert-level #:conn #:monitors #:my-name #:my-passwd #:serialize-data #:remote-node #:dst-port #:remote-passwd #:name #:graph-type #:object + #:proxies #:*proxies* #:*peers* #:*equipment* #:*views* #:*noctool-package* #:id #:last-updated #:unix-host #:linux-host #:cpu-monitor #:load-monitor #:ping-monitor #:remote-node #:decode-base64 #:encode-base64 #:octetify #:destination #:alert-level #:conn #:monitors #:my-name #:my-passwd #:serialize-data #:remote-node #:dst-port #:remote-passwd #:name #:graph-type #:object #:disk-container )) (defpackage #:net.hexapodia.noctool-config @@ -27,5 +27,6 @@ (:export #:cluster #:ping #:load #:machine #:user #:ip #:ssh-port #:disk #:disks #:disk-ignore #:local-password #:local-hostname #:peer)) (defpackage #:net.hexapodia.noctool-network - (:use #:net.hexapodia.noctool #:cl #:usocket) - (:export #:connect #:send #:disconnect #:start-listener)) + (:nicknames #:noctool-network) + (:use #:net.hexapodia.noctool #:cl #:usocket #:net.hexapodia.noctool-scheduler) + (:export #:graph-update #:connect #:send #:disconnect #:start-listener #:list-class #:subscribe #:unsubscribe)) --- /project/noctool/cvsroot/source/scheduler.lisp 2008/06/20 12:19:58 1.3 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/07/03 07:30:24 1.4 @@ -1,6 +1,7 @@ (in-package #:net.hexapodia.noctool-scheduler) (defvar *default-scheduler* nil) +(defvar *network-updates-needed* nil) (defclass event () ((time :reader time :initarg :time) @@ -139,4 +140,4 @@ #-no-noctool-threads (sb-thread:make-thread (lambda () (process (object event)))) #+no-noctool-threads - (process (object event))) \ No newline at end of file + (process (object event))) --- /project/noctool/cvsroot/source/tests.lisp 2008/06/20 12:19:58 1.4 +++ /project/noctool/cvsroot/source/tests.lisp 2008/07/03 07:30:24 1.5 @@ -22,11 +22,13 @@ (* 5 over-rtt)))) (when (graph monitor) (add-value (graph monitor) (reduce #'max data))) - (schedule monitor - (+ (get-universal-time) + (let ((now (get-universal-time))) + (setf (last-updated monitor) now) + (schedule monitor + (+ now (* (interval monitor) - (if (>= (alert-level monitor) *alerting*) 5 1)))))))) + (if (>= (alert-level monitor) *alerting*) 5 1))))))))) (defgeneric process-disk (monitor host)) @@ -95,10 +97,12 @@ (t 0))))))))))))) (defmethod process ((monitor disk-container)) - (process-disk monitor (equipment monitor)) - (schedule monitor (+ (get-universal-time) - (interval monitor))) - ) + (process-disk monitor (equipment monitor)) + (let ((now (get-universal-time))) + (setf (last-updated monitor) now) + (schedule monitor (+ now + (interval monitor)))) + ) (defmethod process ((monitor load-monitor)) (with-pty (pty (make-ssh-command "uptime" (address (equipment monitor)) (username (equipment monitor)))) From imattsson at common-lisp.net Mon Jul 7 15:11:35 2008 From: imattsson at common-lisp.net (imattsson) Date: Mon, 7 Jul 2008 11:11:35 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080707151135.6FF482E2D9@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv3321 Added Files: network-remote-calls.lisp Log Message: IM Oops, this didn't get checked in. --- /project/noctool/cvsroot/source/network-remote-calls.lisp 2008/07/07 15:11:35 NONE +++ /project/noctool/cvsroot/source/network-remote-calls.lisp 2008/07/07 15:11:35 1.1 (in-package :noctool-network) (defun list-class (peer-designator class-designator) (let ((peer (if (stringp peer-designator) (find-peer peer-designator) peer-designator))) (let ((key (cons peer :list-class))) (multiple-value-bind (val exists) (gethash key *reply-structure*) (identity val) (cond (exists (sleep 0.1) (list-class peer class-designator)) (t (setf (gethash key *reply-structure*) nil) (send peer "(request-proxy-class ~a)" class-designator) (loop until (gethash key *reply-structure*) do (sleep 1)) (prog1 (gethash key *reply-structure*) (remhash key *reply-structure*)))))))) (defun subscribe (id peer type) (let ((item nil)) (when (eql type :equipment) (let ((stuff (get-proxy (conn peer) id))) (when (null stuff) (let ((key (cons peer :proxy-equipment))) (setf (gethash key *reply-structure*) nil) (send peer "(request-proxy-equipment ~a)" id) (loop until (gethash key *reply-structure*) do (sleep 1)))) (setf item (object (get-proxy (conn peer) id))) (push item *equipment*))) (when (eql type :graph) (let ((stuff (get-proxy (conn peer) id))) (when (null stuff) (let ((key (cons peer :proxy-graph))) (setf (gethash key *reply-structure*) nil) (send peer "(request-proxy-graph ~a)" id) (loop until (gethash key *reply-structure*) do (sleep 1)))) (setf item (object (get-proxy (conn peer) id))))) item)) (defun graph-update (proxy id value) (send (peer proxy) "(graph-update (id ~a) (measure ~a))" id value)) (defgeneric unsubscribe (thing &optional conn)) (defmethod unsubscribe ((proxy noctool::proxy) &optional conn) (declare (ignore conn)) (unsubscribe (object proxy) (peer proxy))) (defmethod unsubscribe ((e noctool::equipment) &optional conn) (when conn (send conn "(delete-proxy-equipment ~a)" (id e)))) (defmethod unsubscribe ((g noctool-graphs::base-graph) &optional conn) (when conn (send conn "(delete-proxy-graph ~a)" (id g)))) From jprewett at common-lisp.net Wed Jul 9 14:40:07 2008 From: jprewett at common-lisp.net (jprewett) Date: Wed, 9 Jul 2008 10:40:07 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080709144007.3DF9E1F00E@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv18265 Modified Files: scheduler.lisp classes.lisp Log Message: moved :BEFORE PROCESS method for EVENT class into scheduler.lisp --- /project/noctool/cvsroot/source/scheduler.lisp 2008/07/03 07:30:24 1.4 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/07/09 14:40:06 1.5 @@ -141,3 +141,8 @@ (sb-thread:make-thread (lambda () (process (object event)))) #+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 (proxies (equipment obj)) (proxies obj)) + (push obj *network-updates-needed*)))) --- /project/noctool/cvsroot/source/classes.lisp 2008/07/03 07:30:23 1.10 +++ /project/noctool/cvsroot/source/classes.lisp 2008/07/09 14:40:07 1.11 @@ -247,7 +247,4 @@ ) (:default-initargs :display-objects nil)) -(defmethod process :before ((event net.hexapodia.noctool-scheduler:event)) - (let ((obj (net.hexapodia.noctool-scheduler::object event))) - (when (or (proxies (equipment obj)) (proxies obj)) - (push obj *network-updates-needed*)))) + From jprewett at common-lisp.net Tue Jul 22 18:54:46 2008 From: jprewett at common-lisp.net (jprewett) Date: Tue, 22 Jul 2008 14:54:46 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080722185446.074DE7903C@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv10022 Modified Files: graphing.lisp Log Message: added last-updated slot to base-graph class added :AFTER method for add-value to update the last-updated slot with the current time. --- /project/noctool/cvsroot/source/graphing.lisp 2008/07/03 07:30:24 1.6 +++ /project/noctool/cvsroot/source/graphing.lisp 2008/07/22 18:54:45 1.7 @@ -12,7 +12,8 @@ (medium-ix :accessor medium-ix :initarg :medium-ix) (long-ix :accessor long-ix :initarg :long-ix) (interval :reader interval :initarg :interval) - (proxies :accessor proxies :initform nil)) + (proxies :accessor proxies :initform nil) + (last-updated :accessor last-updated :initform NIL)) (:default-initargs :short-ix 0 :medium-ix 0 :long-ix 0 :id (gensym "GRAPH-"))) (defclass gauge-graph (base-graph) @@ -117,6 +118,8 @@ (loop for proxy in (proxies graph) do (noctool-network:graph-update proxy id (id graph) value)))) +(defmethod add-value :after (graph value) + (setf (last-updated graph) (get-universal-time))) (defmethod add-medium ((graph meter-graph)) (when (zerop (mod (medium-ix graph) 12))