[noctool-cvs] CVS source
imattsson
imattsson at common-lisp.net
Sat Jun 14 16:18:04 UTC 2008
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
More information about the noctool-cvs
mailing list