[noctool-cvs] CVS source
imattsson
imattsson at common-lisp.net
Thu Jul 3 07:30:24 UTC 2008
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))))
More information about the noctool-cvs
mailing list