+ deployment. There is web access to the CVS repository and anonymous cvs via cvs -z3 -d :pserver:anonymous:anonymous at common-lisp.net:/project/noctool/cvsroot co source.

From jprewett at common-lisp.net Thu Jun 12 16:04:24 2008 From: jprewett at common-lisp.net (jprewett) Date: Thu, 12 Jun 2008 12:04:24 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080612160424.D319313027@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv15465 Modified Files: noctool.asd Log Message: changed packages that noctool depends upon from strings to symbols to make ASDF-INSTALL happier. --- /project/noctool/cvsroot/source/noctool.asd 2008/05/17 12:32:25 1.3 +++ /project/noctool/cvsroot/source/noctool.asd 2008/06/12 16:04:23 1.4 @@ -4,7 +4,7 @@ :author "Ingvar Mattsson" :license "GPL" :version "0.1" - :depends-on ("usocket" "cl-ppcre" "ironclad" "image") + :depends-on (:usocket :cl-ppcre :ironclad :image) :components ((:file "packages") (:file "globals" :depends-on ("packages")) (:file "generics" :depends-on ("packages" "globals")) From jprewett at common-lisp.net Fri Jun 13 19:15:40 2008 From: jprewett at common-lisp.net (jprewett) Date: Fri, 13 Jun 2008 15:15:40 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080613191540.1FB5A4068@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv10754 Modified Files: classes.lisp Log Message: made equipment set its name or its IP if the other is specified when it is created or signal an error if neither is specified. --- /project/noctool/cvsroot/source/classes.lisp 2008/06/12 13:24:40 1.6 +++ /project/noctool/cvsroot/source/classes.lisp 2008/06/13 19:15:39 1.7 @@ -10,6 +10,38 @@ ) (:default-initargs :id (gensym "EQ-"))) +;; if an instance has a name, but no address, give it an address +;; if an instance has an address, but no name, give it a name +;; if it has neither, signal an error +(defmethod initialize-instance :after ((instance equipment) &key) + (cond ((and (not (slot-boundp instance 'address)) + (not (slot-boundp instance 'name))) + (error "both name and address are unbound for this host!")) + ((not (slot-boundp instance 'address)) + (setf (slot-value instance 'address) + (let ((hostent + (sb-bsd-sockets:host-ent-address + (sb-bsd-sockets:get-host-by-name (name instance))))) + (format NIL "~A.~A.~A.~A" + (aref hostent 0) + (aref hostent 1) + (aref hostent 2) + (aref hostent 3))))) + ((not (slot-boundp instance 'name)) + (setf (slot-value instance 'name) + (sb-bsd-sockets:host-ent-name + (sb-bsd-sockets:get-host-by-address + (let ((arr (make-array '(4)))) + (loop + for i from 0 + for element in + (mapcar #'read-from-string + (cl-ppcre:split #\. (address instance))) + do + (setf (aref arr i) element)) + arr))))))) + + (defclass proxy () ((remote-node :reader remote-node :initarg :remote-node) (object :reader object :initarg :object) From imattsson at common-lisp.net Sat Jun 14 12:08:01 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 08:08:01 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080614120801.8E39A4908D@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv15653 Modified Files: utils.lisp Log Message: IM OCTETIFY failed whenever it tried to convert a 0 or #\Nul --- /project/noctool/cvsroot/source/utils.lisp 2008/06/07 10:24:07 1.7 +++ /project/noctool/cvsroot/source/utils.lisp 2008/06/14 12:08:00 1.8 @@ -178,7 +178,7 @@ append (let ((n (typecase val (character (char-code val)) (integer val)))) - (loop for pos downfrom (* 8 (truncate (floor (log n 2)) 8)) to 0 by 8 + (loop for pos downfrom (* 8 (truncate (floor (log (1+ n) 2)) 8)) to 0 by 8 collect (ldb (byte 8 pos) n)))) '(vector (unsigned-byte 8)))) From imattsson at common-lisp.net Sat Jun 14 12:11:18 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 08:11:18 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080614121118.0E7B2450F4@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv17040 Modified Files: utils.lisp Log Message: IM Really helps if you actually tset before committing. No longer fails on 255 or #\ij-ligature (not, I believe, it's actually called that). --- /project/noctool/cvsroot/source/utils.lisp 2008/06/14 12:08:00 1.8 +++ /project/noctool/cvsroot/source/utils.lisp 2008/06/14 12:11:17 1.9 @@ -178,7 +178,7 @@ append (let ((n (typecase val (character (char-code val)) (integer val)))) - (loop for pos downfrom (* 8 (truncate (floor (log (1+ n) 2)) 8)) to 0 by 8 + (loop for pos downfrom (* 8 (truncate (floor (log (max 1 n) 2)) 8)) to 0 by 8 collect (ldb (byte 8 pos) n)))) '(vector (unsigned-byte 8)))) From imattsson at common-lisp.net Sat Jun 14 12:41:43 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 08:41:43 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080614124143.0AB5B4908D@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv26599 Modified Files: utils.lisp Log Message: IM Now with less compiler warnings. --- /project/noctool/cvsroot/source/utils.lisp 2008/06/14 12:11:17 1.9 +++ /project/noctool/cvsroot/source/utils.lisp 2008/06/14 12:41:43 1.10 @@ -174,13 +174,14 @@ rv)))) (defun octetify (str) - (coerce (loop for val across str - append (let ((n (typecase val - (character (char-code val)) - (integer val)))) - (loop for pos downfrom (* 8 (truncate (floor (log (max 1 n) 2)) 8)) to 0 by 8 - collect (ldb (byte 8 pos) n)))) - '(vector (unsigned-byte 8)))) + (coerce + (loop for val across str + append (let ((n (etypecase val + (character (char-code val)) + (integer val)))) + (loop for pos downfrom (* 8 (truncate (floor (log (max 1 n) 2)) 8)) to 0 by 8 + collect (ldb (byte 8 pos) n)))) + '(vector (unsigned-byte 8)))) (defun encode-base-64-octet-vector (octet-vector) (let ((start octet-vector) From imattsson at common-lisp.net Sat Jun 14 16:15:33 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 12:15:33 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080614161533.5794947145@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv25417 Modified Files: classes.lisp Log Message: IM Test-commit, see if individual commits fixes check-in problems. --- /project/noctool/cvsroot/source/classes.lisp 2008/06/13 19:15:39 1.7 +++ /project/noctool/cvsroot/source/classes.lisp 2008/06/14 16:15:33 1.8 @@ -223,7 +223,7 @@ (remote-passwd :reader remote-passwd :initarg :remote-passwd) (conn :accessor conn :initarg :conn) ) - (:default-initargs :dst-port 23468 :conn nil)) + (:default-initargs :dst-port 11378 :conn nil)) (defmethod remote-passwd ((peer null)) (octetify "a")) From imattsson at common-lisp.net Sat Jun 14 16:18:04 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 12:18:04 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080614161804.2F006620B1@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv25961 Modified Files: network.lisp noctool.asd packages.lisp Log Message: IM Basic networking in place. Need to consider how to handle the protocol dispatching. --- /project/noctool/cvsroot/source/network.lisp 2008/03/17 08:27:58 1.1.1.1 +++ /project/noctool/cvsroot/source/network.lisp 2008/06/14 16:18:04 1.2 @@ -3,12 +3,13 @@ (defvar *incoming* nil) (defvar *local-address* "localhost") (defvar *local-port* 11378) -(defvar *net-package* #.(find-package :net.hexapodia.noctool-network)) +(defvar *net-package* (find-package :net.hexapodia.noctool-network)) (defvar *stop-accept-loop* nil "Variable to control if we need to stop the accept loop") (defvar *connections* nil) +(defvar *class-map* (make-hash-table)) (defclass connection () - ((peer :reader peer :initarg :peer) + ((peer :accessor peer :initarg :peer) (buffer :accessor buffer :initarg :buffer) (buffer-len :accessor buffer-len :initarg :buffer-len) (sock :reader sock :initarg :sock) @@ -17,9 +18,12 @@ (fun-return :accessor fun-return :initarg :fun-return) (nonce1 :accessor nonce1 :initarg :nonce1) (nonce2 :accessor nonce2 :initarg :nonce2) - (authenticated :accessor authenticated :initarg :authenticated) + (state :accessor state :initarg :state) ) - (:default-initargs :nest-depth 0 :authenticated nil)) + (:default-initargs :nest-depth 0 :state :initial)) + +(defun find-peer (name) + (gethash name *peers*)) (defun add-char (conn char) (when (null (vector-push char (buffer conn))) @@ -28,6 +32,11 @@ ) t) + +(declaim (ftype (function (connection) t) + read-word read-string skip-whitespace read-open + read-escaped skip-token)) + (defun read-open (conn) (let ((char (read-char-no-hang (sock conn) nil))) (cond ((null char) nil) @@ -103,22 +112,53 @@ (not (zerop (nest-depth conn)))) (t t)))) +(defun parse-timestring (str) + (or (ignore-errors + (when (and (= (length str) 15) + (= (position #\T str) 8)) + (let ((year (parse-integer str :start 0 :end 4)) + (month (parse-integer str :start 4 :end 6)) + (day (parse-integer str :start 6 :end 8)) + (hour (parse-integer str :start 9 :end 11)) + (min (parse-integer str :start 11 :end 13)) + (sec (parse-integer str :start 13 :end 15))) + (encode-universal-time sec min hour day month year 0)))) + 0)) + +(defun make-timestring () + (let ((now (get-universal-time))) + (multiple-value-bind (sec min hour day mon year) + (decode-universal-time now 0) + (format nil "~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0d" + year mon day hour min sec)))) + +(defun validate-timestring (str) + (let ((then (parse-timestring str)) + (now (get-universal-time))) + (<= 0 (- now then) 50))) + +(defun make-signature (msg password) + (let ((hmac (ironclad:make-hmac password :sha1))) + (ironclad:update-hmac hmac (octetify msg)) + (encode-base64 (ironclad:hmac-digest hmac)))) + (defgeneric send (conn format &rest args)) (defmethod send ((conn connection) format &rest args) (let ((stream (sock conn)) - (peer (get-peer conn))) - (let ((msg (apply #'format nil args)) - (hmac (ironclad:make-hmac (my-password peer) :sha1))) + (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)))))) + (encode-base64 (ironclad:hmac-digest hmac))) + (finish-output stream)))) -(defmethod send ((conn peer) format &rest args) +(defmethod send ((peer remote-node) format &rest args) (apply #'send (conn peer) format args)) (defun protocol-error (conn) - (send conn "(protocol-error)")) + (send conn "(protocol-error)" nil)) (defun make-connection (socket) (make-instance 'connection :peer nil :sock socket @@ -132,23 +172,36 @@ (setf (fill-pointer (buffer conn)) 0) (setf (read-fun conn) #'read-open)) +(defun connect (peer) + (let ((stream (socket-stream (socket-connect (destination peer) + (dst-port peer))))) + (let ((conn (make-connection stream))) + (setf (conn peer) conn) + (setf (peer conn) peer) + (send conn "(iam ~s ~s ~s)" + (my-name peer) + (destination peer) + (make-timestring)) + (setf (state conn) + :sent-validation)))) + (defun handle-read (conn) (loop for rv = (funcall (read-fun conn) conn) until (null rv)) (when (and (zerop (nest-depth conn)) (> (fill-pointer (buffer conn)) 0)) (prog1 - (read-from-string (buffer conn)) + (copy-seq (buffer conn)) (clear-connection conn)))) (defun find-node (name) (find name *peers* :test #'string= :key #'noctool::destination)) -(defun start-listener (&optional force) +(defun start-listener (&key force (port *local-port*) (address *local-address*)) (unless (and *incoming* (not force)) (when *incoming* (socket-close *incoming*)) - (setf *incoming* (socket-listen *local-address* *local-port*)))) + (setf *incoming* (socket-listen address port)))) ;;; Not entirely sure HOW to write this one, at the moment. Could, I suspect, ;;; use threading. @@ -162,22 +215,17 @@ (loop for conn in *connections* do (handle-peer conn))) -(defun check-auth (conn message sent-digest) - (let ((peer (get-peer node))) - (let ((nonce (decode-base64 nonce :result :octet)) - (hmac (ironclad:make-hmac (remote-password peer) :sha1))) - (update-hmac message) - (let ((digest (encode-base64 (ironclad:hmac-digest hmac)))) - (cond ((null peer) - (send conn "(authentication-denied)")) - (t (string= digest sent-digest))))))) +(defun check-signature (conn message digest) + (let ((peer (peer conn))) + (let ((signature (make-signature message (remote-passwd peer)))) + (string= signature digest)))) (defun net-read (message) (let ((*package* *net-package*) - (*read-supress* t) + (*read-suppress* nil) (*read-eval* nil) (*read-base* 10)) - (read message))) + (read-from-string message))) (defun send-proxy-list (conn objects) (let ((objdata (loop for object in objects @@ -199,30 +247,63 @@ (graph-type graph) (serialize-data graph))) +(defun get-class (class-id) + (or (gethash class-id *class-map*) + (let ((package (symbol-package class-id))) + (cond ((eql package *net-package*) + (setf (gethash class-id *class-map*) + (find-class (find-symbol (symbol-name class-id) + *noctool-package*)))) + ((eql package *noctool-package*) + (setf (gethash class-id *class-map*) + (find-class class-id))) + (t (error "Unknown class")))))) + +(defun terminate-conn (conn) + (setf (state conn) :terminated) + (setf *connections* (delete conn *connections*))) + (defun handle-peer (conn) (let ((msg (handle-read conn))) (unless (null msg) - (let ((msg-start (position #\( msg :start 2)) - (msg-end (position #\) msg :start (1- (length msg)) :from-end t))) - (let* ((signature (nth (read msg) 2)) - (message (subseq msg msg-start msg-end)) - (msg (net-read message)) + (let* ((msg-start (position #\( msg :start 2)) + (msg-end (position #\) msg :end (- (length msg) 2) :from-end t)) + (transmission (net-read msg)) + (message (subseq msg msg-start (1+ msg-end))) + (msg (nth 1 transmission)) + (signature (nth 2 transmission)) (head (car msg))) - (ignore-errors - (when (not (authenticated conn)) - (case head - (iam (setf (peer node) (gethash (nth 1 msg) *peers*)) - (when (check-auth conn message signature) - (setf (authenticated conn) t))) - (t (protocol-error conn))) - (when (authenticated conn) - (when (check-auth conn message signature) - (case head - (request-proxy-class - (let ((class (get-class (nth 1 msg)))) - (let ((objects (loop for object in *equipment* - if (typep object class) - collect object))) - (send-proxy-list conn objects)))) - - \ No newline at end of file + (handler-case + (case (state conn) + ((:sent-validation :initial) + (case head + (iam (destructuring-bind + (iam remote-node me time) + msg + (declare (ignorable iam)) + (let ((peer (find-peer remote-node))) + (when (and peer + (string= (my-name peer) + me)) + (when (validate-timestring time) + (setf (peer conn) peer) + (cond ((check-signature conn message signature) + (setf (conn peer) conn) + (when (eql (state conn) :initial) + (send conn "(iam ~s ~s ~s)" + (my-name peer) + (destination peer) + (make-timestring))) + (setf (state conn) :validated)) + (t (protocol-error conn) + (terminate-conn conn)))))))))) + (:validated + (when (check-signature conn message signature) + (case head + (request-proxy-class (destructuring-bind (req class) + msg + (declare (ignorable req)) + (send-proxy-list conn + (get-class class)))) + )))) + (error () (protocol-error conn))))))) --- /project/noctool/cvsroot/source/noctool.asd 2008/06/12 16:04:23 1.4 +++ /project/noctool/cvsroot/source/noctool.asd 2008/06/14 16:18:04 1.5 @@ -1,7 +1,7 @@ (in-package #:cl-user) -(asdf:defsystem "noctool" - :author "Ingvar Mattsson" +(asdf:defsystem :noctool + :author "Ingvar Mattsson / Jim Prewett" :license "GPL" :version "0.1" :depends-on (:usocket :cl-ppcre :ironclad :image) --- /project/noctool/cvsroot/source/packages.lisp 2008/06/12 06:11:00 1.6 +++ /project/noctool/cvsroot/source/packages.lisp 2008/06/14 16:18:04 1.7 @@ -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 + #:*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 )) (defpackage #:net.hexapodia.noctool-config From imattsson at common-lisp.net Sat Jun 14 16:18:37 2008 From: imattsson at common-lisp.net (imattsson) Date: Sat, 14 Jun 2008 12:18:37 -0400 (EDT) Subject: [noctool-cvs] CVS source/docs Message-ID: <20080614161837.42A1E690E2@common-lisp.net> Update of /project/noctool/cvsroot/source/docs In directory clnet:/tmp/cvs-serv26098 Modified Files: noctool-protocol.txt Log Message: IM Updated network protocol spec. --- /project/noctool/cvsroot/source/docs/noctool-protocol.txt 2008/06/06 06:18:33 1.1 +++ /project/noctool/cvsroot/source/docs/noctool-protocol.txt 2008/06/14 16:18:37 1.2 @@ -14,7 +14,12 @@ *Session control **Session initialisation - (iam ) + (iam

) + + Datestring is the UTC time and date of sending the message and should + be considered stale if older than a few seconds. The date and time MUST be + formatted as YYYYMMDDTHHMMSS (as an example, 20080609T155637). + **Session termination Either party sends: (session-terminate) From imattsson at common-lisp.net Sun Jun 15 10:45:28 2008 From: imattsson at common-lisp.net (imattsson) Date: Sun, 15 Jun 2008 06:45:28 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080615104528.4E80D4814D@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv12629 Modified Files: network.lisp packages.lisp Added Files: network-utils.lisp network-globals.lisp Log Message: IM Split the network file into three (network, network-globals, network-utils) to make space for a DEHANDLER macro (to define protocll handlers). We're now dispatching protocol messages keyed off the protocol request via a hash-table, pointing at the function we want to call. Also exported OBJECT from the main noctool package. --- /project/noctool/cvsroot/source/network.lisp 2008/06/14 16:18:04 1.2 +++ /project/noctool/cvsroot/source/network.lisp 2008/06/15 10:45:23 1.3 @@ -1,13 +1,5 @@ (in-package #:net.hexapodia.noctool-network) -(defvar *incoming* nil) -(defvar *local-address* "localhost") -(defvar *local-port* 11378) -(defvar *net-package* (find-package :net.hexapodia.noctool-network)) -(defvar *stop-accept-loop* nil "Variable to control if we need to stop the accept loop") -(defvar *connections* nil) -(defvar *class-map* (make-hash-table)) - (defclass connection () ((peer :accessor peer :initarg :peer) (buffer :accessor buffer :initarg :buffer) @@ -259,10 +251,49 @@ (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 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))) + +(defhandler request-proxy-equipment (request-proxy-equipment eq-id) + (let ((equipment (find eq-id *equipment* :key #'id))) + (when equipment + (send-proxy-equipment conn equipment)))) + +(defhandler proxy-equipment (proxy-equipment &rest modifiers) + (let ((classes nil) + (monitors nil) + (id nil) + (name nil)) + (loop for (opname . opvals) in modifiers + do (case opname + (id (setf id (car opvals))) + (classes (setf classes opvals)) + (monitors (setf monitors opvals)) + (name (setf name (car opvals))))) + (let ((proxy (get-proxy 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))) + (when (and monitors (null (monitors object))) + ;; Build monitor list and chuck it on the monitors-list + ))))) + (defun handle-peer (conn) (let ((msg (handle-read conn))) (unless (null msg) @@ -299,11 +330,8 @@ (terminate-conn conn)))))))))) (:validated (when (check-signature conn message signature) - (case head - (request-proxy-class (destructuring-bind (req class) - msg - (declare (ignorable req)) - (send-proxy-list conn - (get-class class)))) - )))) + (let ((handler (gethash head *handler-map*))) + (cond (handler (apply handler conn msg)) + (t (protocol-error conn)))) + ))) (error () (protocol-error conn))))))) --- /project/noctool/cvsroot/source/packages.lisp 2008/06/14 16:18:04 1.7 +++ /project/noctool/cvsroot/source/packages.lisp 2008/06/15 10:45:25 1.8 @@ -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 + #:*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 )) (defpackage #:net.hexapodia.noctool-config --- /project/noctool/cvsroot/source/network-utils.lisp 2008/06/15 10:45:28 NONE +++ /project/noctool/cvsroot/source/network-utils.lisp 2008/06/15 10:45:28 1.1 (in-package :net.hexapodia.noctool-network) (defmacro defhandler (name (proto-sym &rest llist) &body body) "Define a handler for VALIDATED part of a connection, it will add an argument called CONN as the very first element. This is the connection that the request came in over. Validation of the signature is done before any dispatching. The first argument should be the protocol symbol to dispatch on, it is declared as IGNORABLE, the rest of the parameters should map to the protocol request." (setf (gethash proto-sym *handler-map*) name) `(defun ,name (conn ,proto-sym , at llist) (declare (ignorable ,proto-sym)) , at body)) --- /project/noctool/cvsroot/source/network-globals.lisp 2008/06/15 10:45:28 NONE +++ /project/noctool/cvsroot/source/network-globals.lisp 2008/06/15 10:45:28 1.1 (in-package :net.hexapodia.noctool-network) (defvar *incoming* nil) (defvar *local-address* "localhost") (defvar *local-port* 11378) (defvar *net-package* (find-package :net.hexapodia.noctool-network)) (defvar *stop-accept-loop* nil "Variable to control if we need to stop the accept loop") (defvar *connections* nil) (defvar *class-map* (make-hash-table)) (defvar *handler-map* (make-hash-table)) (defvar *proxies* (make-hash-table)) From imattsson at common-lisp.net Tue Jun 17 06:00:36 2008 From: imattsson at common-lisp.net (imattsson) Date: Tue, 17 Jun 2008 02:00:36 -0400 (EDT) Subject: [noctool-cvs] CVS source/docs Message-ID: <20080617060036.5EA6C117D@common-lisp.net> Update of /project/noctool/cvsroot/source/docs In directory clnet:/tmp/cvs-serv21230 Modified Files: noctool-protocol.txt Log Message: IM Just realised, while I believe that monitor IDs and equipment IDs are locally distinct, it is better to have separate protocol requests for dumping one or the other. --- /project/noctool/cvsroot/source/docs/noctool-protocol.txt 2008/06/14 16:18:37 1.2 +++ /project/noctool/cvsroot/source/docs/noctool-protocol.txt 2008/06/17 06:00:32 1.3 @@ -55,5 +55,5 @@ (proxy-equipment ...)) **Deleting proxies - (delete-proxy ) - \ No newline at end of file + (delete-proxy-equipment ) + (delete-proxy-monitor ) From jprewett at common-lisp.net Tue Jun 17 11:03:58 2008 From: jprewett at common-lisp.net (jprewett) Date: Tue, 17 Jun 2008 07:03:58 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080617110358.6AFE4620B5@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv22656 Modified Files: monitors.lisp Log Message: it was really bugging me that the expression wasn't closed :P --- /project/noctool/cvsroot/source/monitors.lisp 2008/03/17 08:27:58 1.1.1.1 +++ /project/noctool/cvsroot/source/monitors.lisp 2008/06/17 11:03:58 1.2 @@ -5,4 +5,4 @@ (let ((name (name host))) ;; NB, the actual ping command needs to be tuned to the ;; underlying platform OR we need to implement ICMP in lisp. - \ No newline at end of file + ))) From jprewett at common-lisp.net Fri Jun 20 12:19:58 2008 From: jprewett at common-lisp.net (jprewett) Date: Fri, 20 Jun 2008 08:19:58 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080620121958.37A2BA103@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv7636 Modified Files: classes.lisp graph-monitors.lisp graphing.lisp scheduler.lisp tests.lisp Log Message: factored out the ID slot from the EQUIPMENT, MONITOR, and BASE-GRAPH classes. Created ID-OBJECT mixin class with :AFTER method that causes the instance to be added to the *ID-OBJECTS* hash table. Instances may be retrieved using the newly added GET-INSTANCE-BY-ID macro. Modified NEXT-TIMESLOT so if it is called without the optional scheduler and there is no *DEFAULT-SCHEDULER*, a default scheduler is created and bound to *DEFAULT-SCHEDULER*. Modified PARSE-DF so that if it is given a line, like an automount line on MacOS, it munges the line into something useable. This is sort-of *(OK, REALLY)* kludgy but it makes it so NOCtool doesn't blow up on my Mac :) . Also modified PARSE-DF so that it says the disk is 100% full if there is 0 available space instead of signaling a DIVIDE-BY-ZERO error. Added SHOW method for DISK-CONTAINER class. --- /project/noctool/cvsroot/source/classes.lisp 2008/06/14 16:15:33 1.8 +++ /project/noctool/cvsroot/source/classes.lisp 2008/06/20 12:19:57 1.9 @@ -1,8 +1,20 @@ (in-package #:noctool) -(defclass equipment () + +;; a hash so we can look up objects by their ID +(defvar *id-objects* (make-hash-table :test #'equal)) +(defclass id-object () + ((id :reader id :initarg :id))) + +(defmethod initialize-instance :after ((instance id-object) &key) + (setf (gethash (symbol-name (id instance)) *id-objects*) + instance)) + +(defmacro get-instance-by-id (id-string) + `(gethash ,id-string *id-objects*)) + +(defclass equipment (id-object) ((monitors :accessor monitors :initarg :monitors :initform nil) - (id :reader id :initarg :id) (name :reader name :initarg :name) (address :reader address :initarg :address) (username :reader username :initarg :username :initform nil) @@ -47,9 +59,8 @@ (object :reader object :initarg :object) )) -(defclass monitor () +(defclass monitor (id-object) ((equipment :reader equipment :initarg :equipment) - (id :reader id :initarg :id) (alert-level :accessor alert-level :initarg :alert-level :initform 0) (interval :accessor interval :initarg :interval :initform 300) (last-updated :accessor last-updated :initarg :last-updated) --- /project/noctool/cvsroot/source/graph-monitors.lisp 2008/05/17 17:27:26 1.4 +++ /project/noctool/cvsroot/source/graph-monitors.lisp 2008/06/20 12:19:57 1.5 @@ -97,6 +97,25 @@ t (nth 0 color) (nth 1 color)(nth 2 color))))) image))) +(defmethod show ((graph noctool::disk-container) sink format &key (selector :short) scale &allow-other-keys) + (let ((lines (length (noctool::disk-list graph))) + (disks (sort (copy-list (noctool::disk-list graph)) #'> :key #'noctool::disk-max))) + (let ((image (image:make-image 350 (+ 130 (* 10 lines))))) + (image:rect image 0 0 349 (1- (image::height image)) t 192 192 192) + (multiple-value-bind (percentile max scale) (show (noctool::disk-graph (car disks)) image nil :color '(0 0 0 0.0) :base-x 25 :base-y 110 :height 100 :selector selector) + (draw-grid image max (interval graph) selector scale "b" 3 (noctool:last-updated graph)) + (loop for disk in disks + for color in *graph-colors* + for text-offset = 125 then (+ text-offset 10) + for style = :line then :plot + do (let ((graph (noctool::disk-graph disk)) + (text (format nil "~a [ ~a ]" (noctool::mountpoint disk) (noctool::device disk)))) + (show graph image nil :color color :scale scale :height 100 :base-y 110 :base-x 25 :selector selector :style style) + (image:text image text 25 text-offset 0 0 0) + (image:rect image 15 text-offset 20 (+ 5 text-offset) + t (nth 0 color) (nth 1 color)(nth 2 color))))) + image))) + (defmethod show :around ((graph noctool::monitor) (sink string) format &key (selector :short) scale &allow-other-keys) (let ((image (call-next-method))) (image:export-to-gif image sink))) --- /project/noctool/cvsroot/source/graphing.lisp 2008/05/17 17:25:47 1.3 +++ /project/noctool/cvsroot/source/graphing.lisp 2008/06/20 12:19:57 1.4 @@ -4,14 +4,13 @@ (:meter . meter-graph) (:gauge-avg . avg-graph) (:gauge-max . max-graph))) ;;; Graph storage classes -(defclass base-graph () +(defclass base-graph (noctool::id-object) ((short :reader short :initarg :short) (medium :reader medium :initarg :medium) (long :reader long :initarg :long) (short-ix :accessor short-ix :initarg :short-ix) (medium-ix :accessor medium-ix :initarg :medium-ix) (long-ix :accessor long-ix :initarg :long-ix) - (id :reader id :initarg :id) (interval :reader interval :initarg :interval) (proxies :accessor proxies :initform nil)) (:default-initargs :short-ix 0 :medium-ix 0 :long-ix 0 :id (gensym "GRAPH-"))) --- /project/noctool/cvsroot/source/scheduler.lisp 2008/05/16 19:23:06 1.2 +++ /project/noctool/cvsroot/source/scheduler.lisp 2008/06/20 12:19:58 1.3 @@ -25,6 +25,7 @@ foo) (defmethod first-timeslot ((foo null)) foo) + (defmethod last-timeslot ((foo null)) foo) (defmethod prev ((foo null)) @@ -105,6 +106,10 @@ (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))) --- /project/noctool/cvsroot/source/tests.lisp 2008/05/29 19:21:38 1.3 +++ /project/noctool/cvsroot/source/tests.lisp 2008/06/20 12:19:58 1.4 @@ -39,13 +39,17 @@ with last = NIL for len = (+ (length split) (length last)) while line - when (> 6 len) + if (> 6 len) do (setf last split) else do - (push (nconc last split) ret) - (setf last NIL)) + (let ((result (nconc last split))) + (if (= (length result) 8) + (push (cons (format NIL "~A-~A" (car result) (cadr result)) + (cdddr result)) ret) + (push result ret)) + (setf last NIL))) ret)) @@ -79,7 +83,7 @@ (setf (mountpoint platter) mount) (setf (disk-free platter) free) (add-value (disk-graph platter) used) - (let ((percent (* 100 (/ used disk)))) + (let ((percent (if (= 0 disk) 100 (* 100 (/ used disk))))) (setf (alert-level platter) (decay-alert (alert-level platter) From jprewett at common-lisp.net Sat Jun 21 11:07:36 2008 From: jprewett at common-lisp.net (jprewett) Date: Sat, 21 Jun 2008 07:07:36 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080621110736.D99B32E183@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv24095 Modified Files: graphing.lisp Log Message: Modified SHOW method for PERCENTILE-GRAPH-DISPLAY class so that the computation of the scale won't cause a DIVISION-BY-ZERO error when the max of the selected data is 0. --- /project/noctool/cvsroot/source/graphing.lisp 2008/06/20 12:19:57 1.4 +++ /project/noctool/cvsroot/source/graphing.lisp 2008/06/21 11:07:36 1.5 @@ -267,7 +267,8 @@ (let ((tmpdata (sort (copy-seq data) #'<))) (let ((percentile (aref tmpdata (round (* (length tmpdata) (/ (percentile graph) 100)))))) (let ((scale (or scale (if (zerop percentile) - (/ height (reduce #'max tmpdata)) + (/ height (let ((max (reduce #'max tmpdata))) + (if (eql 0 max) 1 max))) (/ height percentile))))) (loop for n from 0 for value across data From imattsson at common-lisp.net Sun Jun 22 11:02:21 2008 From: imattsson at common-lisp.net (imattsson) Date: Sun, 22 Jun 2008 07:02:21 -0400 (EDT) Subject: [noctool-cvs] CVS source Message-ID: <20080622110221.DBB5EA12E@common-lisp.net> Update of /project/noctool/cvsroot/source In directory clnet:/tmp/cvs-serv21204 Modified Files: graph-monitors.lisp Log Message: IM Added a GRAPH-IGNORE "make ignored vars" style-warnings go away. --- /project/noctool/cvsroot/source/graph-monitors.lisp 2008/06/20 12:19:57 1.5 +++ /project/noctool/cvsroot/source/graph-monitors.lisp 2008/06/22 11:02:21 1.6 @@ -7,6 +7,10 @@ (-12 . "p") (12 . "T"))) (defvar *days* #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) +(defun graph-ignore (&rest args) + (declare (ignore args)) + nil) + (defun nearest-multiplier (n) (let ((pow (log n 10))) (multiple-value-bind (floor mod) @@ -76,33 +80,48 @@ (image:rect image 0 0 349 139 t 240 240 240) (multiple-value-bind (percentile max scale) (show (noctool::graph graph) image nil :selector selector :scale scale) + (graph-ignore percentile max scale) ))) (defmethod show ((graph noctool::disk-container) sink format &key (selector :short) scale &allow-other-keys) + (graph-ignore scale) (let ((lines (length (noctool::disk-list graph))) (disks (sort (copy-list (noctool::disk-list graph)) #'> :key #'noctool::disk-max))) (let ((image (image:make-image 350 (+ 130 (* 10 lines))))) (image:rect image 0 0 349 (1- (image::height image)) t 192 192 192) - (multiple-value-bind (percentile max scale) (show (noctool::disk-graph (car disks)) image nil :color '(0 0 0 0.0) :base-x 25 :base-y 110 :height 100 :selector selector) + (multiple-value-bind (percentile max scale) + (show (noctool::disk-graph (car disks)) image nil + :color '(0 0 0 0.0) + :base-x 25 :base-y 110 :height 100 :selector selector) + (graph-ignore percentile) (draw-grid image max (interval graph) selector scale "b" 3 (noctool:last-updated graph)) (loop for disk in disks for color in *graph-colors* for text-offset = 125 then (+ text-offset 10) for style = :line then :plot do (let ((graph (noctool::disk-graph disk)) - (text (format nil "~a [ ~a ]" (noctool::mountpoint disk) (noctool::device disk)))) - (show graph image nil :color color :scale scale :height 100 :base-y 110 :base-x 25 :selector selector :style style) + (text (format nil "~a [ ~a ]" + (noctool::mountpoint disk) + (noctool::device disk)))) + (show graph image nil :color color :scale scale + :height 100 :base-y 110 :base-x 25 + :selector selector :style style) (image:text image text 25 text-offset 0 0 0) (image:rect image 15 text-offset 20 (+ 5 text-offset) t (nth 0 color) (nth 1 color)(nth 2 color))))) image))) (defmethod show ((graph noctool::disk-container) sink format &key (selector :short) scale &allow-other-keys) + (graph-ignore scale) (let ((lines (length (noctool::disk-list graph))) (disks (sort (copy-list (noctool::disk-list graph)) #'> :key #'noctool::disk-max))) (let ((image (image:make-image 350 (+ 130 (* 10 lines))))) (image:rect image 0 0 349 (1- (image::height image)) t 192 192 192) - (multiple-value-bind (percentile max scale) (show (noctool::disk-graph (car disks)) image nil :color '(0 0 0 0.0) :base-x 25 :base-y 110 :height 100 :selector selector) + (multiple-value-bind (percentile max scale) + (show (noctool::disk-graph (car disks)) image nil + :color '(0 0 0 0.0) :base-x 25 :base-y 110 :height 100 + :selector selector) + (graph-ignore percentile) (draw-grid image max (interval graph) selector scale "b" 3 (noctool:last-updated graph)) (loop for disk in disks for color in *graph-colors* @@ -117,5 +136,6 @@ image))) (defmethod show :around ((graph noctool::monitor) (sink string) format &key (selector :short) scale &allow-other-keys) + (graph-ignore selector scale) (let ((image (call-next-method))) (image:export-to-gif image sink)))

Current status