Thread: [brlcad-commits] SF.net SVN: brlcad:[44098] geomcore/trunk/src/interfaces/cl
Open Source Solid Modeling CAD
Brought to you by:
brlcad
From: <eri...@us...> - 2011-03-30 21:39:45
|
Revision: 44098 http://brlcad.svn.sourceforge.net/brlcad/?rev=44098&view=rev Author: erikgreenwald Date: 2011-03-30 21:39:38 +0000 (Wed, 30 Mar 2011) Log Message: ----------- break GS net ops into seperate package Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.asd geomcore/trunk/src/interfaces/cl/gsclient.lisp Added Paths: ----------- geomcore/trunk/src/interfaces/cl/gsnet.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.asd =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.asd 2011-03-30 21:22:09 UTC (rev 44097) +++ geomcore/trunk/src/interfaces/cl/gsclient.asd 2011-03-30 21:39:38 UTC (rev 44098) @@ -10,5 +10,6 @@ :long-description "Common Lisp client interface for the BRL-CAD Geometry Service protocol" :serial t :depends-on (:usocket :uuid) - :components ((:file "gsclient"))) + :components ((:file "gsnet") + (:file "gsclient"))) Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-03-30 21:22:09 UTC (rev 44097) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-03-30 21:39:38 UTC (rev 44098) @@ -7,180 +7,36 @@ (in-package :gsclient) -(defparameter +nodename+ "Geist") -(defconstant +magic+ #x41fe5309) - -;;; message types -(defconstant +gsrualive+ #x0042) ; Test if server is up -(defconstant +gsimalive+ #x0043) ; Expected response from running server to GSRUALIVE -(defconstant +gsfail+ #x0050) ; Failure -(defconstant +gsok+ #x0051) ; Success -(defconstant +gsping+ #x0060) ; Ping -(defconstant +gspong+ #x0062) ; Pong -(defconstant +gsrnnset+ #x0100) ; GS Remote Nodename Set -(defconstant +gsdr+ #x0150) ; Disconnect Request -(defconstant +gsnnnet+ #x0200) ; New Node on Network -(defconstant +gsfnlr+ #x0250) ; Full Nodename List Request (Not implemented yet) -(defconstant +gsfnl+ #x0255) ; Full Nodename List (Not implemented yet) -(defconstant +gsnsr+ #x0300) ; New Session Request -(defconstant +gsinfo+ #x0305) ; Session Information -(defconstant +gsgr+ #x0400) ; Geometry Request -(defconstant +gsgm+ #x0405) ; Geometry Manifest -(defconstant +gsgc+ #x0410) ; Geometry Chunk - -(defun usec () (multiple-value-bind (_ sec usec) (sb-unix:unix-gettimeofday) (declare (ignore _)) (+ (* 1000000 sec) usec))) - -;;; utility functions to write out -(defun writeuint64 (s i) (loop for a in '(56 48 40 32 24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) -(defun writeuint32 (s i) (loop for a in '(24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) -(defun writeuint16 (s i) (loop for a in '(8 0) do (write-byte (ldb (byte 8 a) i) s))) -(defun writegsstring (s str) (writeuint32 s (length str)) (loop for x being the element of str do (if x (write-byte (char-code x) s)))) - -;;; utility functions to read in -(defun readuint64 (s) (loop with i = 0 for a in '(56 48 40 32 24 16 8 0) do (dpb (read-byte s) (byte 8 a) i) finally (return i))) -(defun readuint32 (s) (+ (* (read-byte s) #x1000000) (* (read-byte s) #x10000) (* (read-byte s) #x100) (read-byte s))) -(defun readuint16 (s) (+ (* #x100 (read-byte s)) (read-byte s))) -(defun readgsstring (s) - (let ((length (readuint32 s))) - (loop with str = (make-string length) for i from 0 to (- length 1) - do (setf (char str i) (code-char (read-byte s))) finally (return str)))) -(defun readuuid (s) (uuid:make-uuid-from-string (readgsstring s))) -(defun readmagic (s) (= +magic+ (readuint32 s))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass session () - ((localnode :accessor localnode :initform +nodename+) - (remotenode :accessor remotenode) - (sessionuuid :accessor sessionuuid :initform '()) - (username :accessor username :initarg :username) - (password :accessor password :initarg :password) - (host :accessor host :initarg :host) - (port :accessor port :initarg :port) - (strm :accessor strm :initform 'nil) - (socket :accessor socket :initform 'nil))) - -(defclass message () - ((msgtype :accessor msgtype :initarg :msgtype) - (uuid :accessor uuid :initarg :uuid :initform (format '() "~a" (uuid:make-v4-uuid))) - (reuuid :accessor reuuid :initarg :reuuid :initform '()) - (len :accessor len :initform 0))) - - -;;; snarf data off the line and return an instance of the right kind of class -(defun readmsg (s) - (if (readmagic (strm s)) - (let ((length (readuint32 (strm s))) - (type (readuint16 (strm s))) - (uuid (readgsstring (strm s))) - (reuuid (if (= (read-byte (strm s)) 1) (readuuid (strm s)) '()))) - (setf length (- length (+ 2 4 (length uuid) (if reuuid (+ (length reuuid) 4) 0) 1))) - (cond - ((= type +gsrnnset+) (setf (remotenode s) (readgsstring (strm s))) type) - ((= type +gspong+) (make-instance 'pongmsg :tv (readuint64 (strm s)))) - ((= type +gsping+) (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s))))) ; automatically respond to ping requests - ((= type +gsinfo+) (setf (sessionuuid s) (readgsstring (strm s))) type) - ((= type +gsfail+) (make-instance 'failmsg)) - ((= type +gsok+) (make-instance 'okmsg)) - ((= type +gsrualive+) (writemsg s (make-instance 'imalivemsg))) ; automatically respond to rualive - ((= type +gsimalive+) (make-instance 'imalivemsg)) - ((= type +gsgr+) (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) - ((= type +gsgm+) (make-instance 'geommanifestreq :manifest (loop for i from 0 to (readuint32 (strm s)) collect (readgsstring (strm s))))) - ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk (let ((len (readuint32 (strm s)))) (loop with c = (make-array len :element-type '(unsigned-byte 8)) for i from 0 to len do (setf (aref c i) (read-byte (strm s))))))) - (t (format t "Unknown type! ~x~%" type)))) - '())) - -(defgeneric writemsg (session message) (:documentation "Send the message to the socket stream")) - -;;; common to all messages -(defmethod writemsg :before (s (m message)) (setf (len m) (+ (len m) 7 (length (uuid m)) (if (reuuid m) (+ (length (reuuid m)) 4) 0) ))) -(defmethod writemsg (s (m message)) - (writeuint32 (strm s) +magic+) - (writeuint32 (strm s) (len m)) - (writeuint16 (strm s) (msgtype m)) - (writegsstring (strm s) (uuid m)) - (if (reuuid m) - (progn (write-byte 1 (strm s)) (writegsstring (strm s) (reuuid m))) - (write-byte 0 (strm s)))) -(defmethod writemsg :around (s (m message)) (call-next-method) (force-output (strm s))) - -;;; type specific send handling -(defclass pingmsg (message) ((tv :accessor tv :initform (usec)))) -(defmethod writemsg :before (s (m pingmsg)) (setf (msgtype m) +gsping+) (setf (len m) 8)) -(defmethod writemsg :after (s (m pingmsg)) (format t "Pinging with ~a~%" (tv m)) (writeuint64 (strm s) (tv m))) - -(defclass pongmsg (message) ((tv :accessor tv :initarg :tv))) -(defmethod writemsg :before (s (m pongmsg)) (setf (msgtype m) +gspong+) (setf (len m) 8)) -(defmethod writemsg :after (s (m pongmsg)) (writeuint64 (strm s) (tv m))) - -(defclass nodenamemsg (message) ((name :accessor name :initarg :name))) -(defmethod writemsg :before (s (m nodenamemsg)) (setf (msgtype m) +gsrnnset+) (setf (len m) (+ (length (localnode s)) 4))) -(defmethod writemsg :after (s (m nodenamemsg)) (writegsstring (strm s) (localnode s))) - -(defclass loginmsg (message) ()) -(defmethod writemsg :before (s (m loginmsg)) (setf (msgtype m) +gsnsr+) (setf (len m) (+ (length (username s)) (length (password s)) 8))) -(defmethod writemsg :after (s (m loginmsg)) (writegsstring (strm s) (username s)) (writegsstring (strm s) (password s))) - -(defclass logoutmsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsdr+)) - -(defclass rualivemsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsrualive+)) - -(defclass imalivemsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsimalive+)) - -(defclass okmsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsok+)) - -(defclass failmsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsfail+)) - -(defclass geomreqmsg (message) ((uri :accessor uri :initarg :uri :initform ""))) -(defmethod writemsg :before (s (m geomreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) -(defmethod writemsg :after (s (m geomreqmsg)) (writegsstring (strm s) (uri m))) - -(defclass geommanifestmsg (message) ((manifest :accessor manifest :initarg :manifest))) -(defmethod writemsg :before (s (m geommanifestmsg)) - (setf (msgtype m) +gsgm+) - (setf (len m) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))))) -(defmethod writemsg :after (s (m geomreqmsg)) (writeuint32 (strm s) (length (manifest m))) - (loop for i in (manifest m) do (writegsstring (strm s) i))) - -(defclass geomchunkmsg (message) ((chunk :accessor chunk :initarg :chunk))) -(defmethod writemsg :before (s (m geomchunkmsg)) (setf (msgtype m) +gsgc+) (setf (len m) (length (chunk m)))) -(defmethod writemsg :after (s (m geomchunkmsg)) (writeuint32 (strm s) (length (chunk m))) (loop for i from 0 to (length (chunk m)) do (write-byte (aref (chunk m) i) (strm s)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; public interface ;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun getgeom (s st uri) - (writemsg s (make-instance 'geomreqmsg :uri uri)) - (let ((mfst (readmsg s))) - (loop for i from 0 to (length (manifest mfst)) do - (let ((cm (chunk (readmsg (strm s))))) + (gsnet:writemsg s (make-instance 'geomreqmsg :uri uri)) + (let ((mfst (gsnet:readmsg s))) + (loop for i from 0 to (length (gsnet:manifest mfst)) do + (let ((cm (chunk (gsnet:readmsg (strm s))))) (loop for j from 0 to (length cm) do (write-byte (aref cm j) st)))))) (defun ping (s) - (writemsg s (make-instance 'pingmsg)) - (let ((m (readmsg s))) - (format t "response holds: ~a~%" (tv m)) - (- (usec) (tv m)))) + (gsnet:writemsg s (make-instance 'gsnet:pingmsg)) + (let ((m (gsnet:readmsg s))) + (format t "response holds: ~a~%" (gsnet::tv m)) + (- (gsnet:usec) (gsnet::tv m)))) ; log in to a server, returning the session (defun login (&key (username "Guest") (password "Guest") (host #(127 0 0 1)) (port 5309)) - (let ((s (make-instance 'session :host host :port port :username username :password password))) - (setf (socket s) (usocket:socket-connect host port :element-type '(unsigned-byte 8))) - (setf (strm s) (usocket:socket-stream (socket s))) - (readmsg s) - (writemsg s (make-instance 'nodenamemsg :name (localnode s))) - (format t "Remote name: ~a~%" (remotenode s)) - (writemsg s (make-instance 'loginmsg)) - (readmsg s) - (format t "Session UUID: ~a~%" (sessionuuid s)) + (let ((s (make-instance 'gsnet:session :host host :port port :username username :password password))) + (setf (gsnet::socket s) (usocket:socket-connect host port :element-type '(unsigned-byte 8))) + (setf (gsnet::strm s) (usocket:socket-stream (gsnet:socket s))) + (gsnet:readmsg s) + (gsnet:writemsg s (make-instance 'gsnet:nodenamemsg :name (gsnet::localnode s))) + (format t "Remote name: ~a~%" (gsnet:remotenode s)) + (gsnet:writemsg s (make-instance 'gsnet:loginmsg)) + (gsnet:readmsg s) + (format t "Session UUID: ~a~%" (gsnet:sessionuuid s)) s)) (defun logout (s) - (writemsg s (make-instance 'logoutmsg)) - (usocket:socket-close (socket s))) \ No newline at end of file + (gsnet:writemsg s (make-instance 'gsnet:logoutmsg)) + (usocket:socket-close (gsnet:socket s))) Added: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp (rev 0) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-03-30 21:39:38 UTC (rev 44098) @@ -0,0 +1,155 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(in-package :cl-user) + +(defpackage :gsnet + (:use :cl :sb-unix) + (:export :connect :writemsg :readmsg + :session :message :pingmsg :pongmsg :nodenamemsg :loginmsg :logoutmsg :rualivemsg :imalivemsg :okmsg :failmsg :geomreqmsg :geommanifestmsg :geomchunkmsg + :manifest :remotenode :sessionuuid :socket :strm + :usec)) + +(in-package :gsnet) + +(defparameter +nodename+ "Geist") +(defconstant +magic+ #x41fe5309) + +;;; message types +(defconstant +gsrualive+ #x0042) ; Test if server is up +(defconstant +gsimalive+ #x0043) ; Expected response from running server to GSRUALIVE +(defconstant +gsfail+ #x0050) ; Failure +(defconstant +gsok+ #x0051) ; Success +(defconstant +gsping+ #x0060) ; Ping +(defconstant +gspong+ #x0062) ; Pong +(defconstant +gsrnnset+ #x0100) ; GS Remote Nodename Set +(defconstant +gsdr+ #x0150) ; Disconnect Request +(defconstant +gsnnnet+ #x0200) ; New Node on Network +(defconstant +gsfnlr+ #x0250) ; Full Nodename List Request (Not implemented yet) +(defconstant +gsfnl+ #x0255) ; Full Nodename List (Not implemented yet) +(defconstant +gsnsr+ #x0300) ; New Session Request +(defconstant +gsinfo+ #x0305) ; Session Information +(defconstant +gsgr+ #x0400) ; Geometry Request +(defconstant +gsgm+ #x0405) ; Geometry Manifest +(defconstant +gsgc+ #x0410) ; Geometry Chunk + +(defun usec () (multiple-value-bind (_ sec usec) (sb-unix:unix-gettimeofday) (declare (ignore _)) (+ (* 1000000 sec) usec))) + +;;; utility functions to write out +(defun writeuint64 (s i) (loop for a in '(56 48 40 32 24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) +(defun writeuint32 (s i) (loop for a in '(24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) +(defun writeuint16 (s i) (loop for a in '(8 0) do (write-byte (ldb (byte 8 a) i) s))) +(defun writegsstring (s str) (writeuint32 s (length str)) (loop for x being the element of str do (if x (write-byte (char-code x) s)))) + +;;; utility functions to read in +(defun readuint64 (s) (loop with i = 0 for a in '(56 48 40 32 24 16 8 0) do (dpb (read-byte s) (byte 8 a) i) finally (return i))) +(defun readuint32 (s) (+ (* (read-byte s) #x1000000) (* (read-byte s) #x10000) (* (read-byte s) #x100) (read-byte s))) +(defun readuint16 (s) (+ (* #x100 (read-byte s)) (read-byte s))) +(defun readgsstring (s) + (let ((length (readuint32 s))) + (loop with str = (make-string length) for i from 0 to (- length 1) + do (setf (char str i) (code-char (read-byte s))) finally (return str)))) +(defun readuuid (s) (uuid:make-uuid-from-string (readgsstring s))) +(defun readmagic (s) (= +magic+ (readuint32 s))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass session () + ((localnode :accessor localnode :initform +nodename+) + (remotenode :accessor remotenode) + (sessionuuid :accessor sessionuuid :initform '()) + (username :accessor username :initarg :username) + (password :accessor password :initarg :password) + (host :accessor host :initarg :host) + (port :accessor port :initarg :port) + (strm :accessor strm :initform 'nil) + (socket :accessor socket :initform 'nil))) + +(defclass message () + ((msgtype :accessor msgtype :initarg :msgtype) + (uuid :accessor uuid :initarg :uuid :initform (format '() "~a" (uuid:make-v4-uuid))) + (reuuid :accessor reuuid :initarg :reuuid :initform '()) + (len :accessor len :initform 0))) + +;;; snarf data off the line and return an instance of the right kind of class +(defun readmsg (s) + (if (readmagic (strm s)) + (let ((length (readuint32 (strm s))) + (type (readuint16 (strm s))) + (uuid (readgsstring (strm s))) + (reuuid (if (= (read-byte (strm s)) 1) (readuuid (strm s)) '()))) + (setf length (- length (+ 2 4 (length uuid) (if reuuid (+ (length reuuid) 4) 0) 1))) + (cond + ((= type +gsrnnset+) (setf (remotenode s) (readgsstring (strm s))) type) + ((= type +gspong+) (make-instance 'pongmsg :tv (readuint64 (strm s)))) + ((= type +gsping+) (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s))))) ; automatically respond to ping requests + ((= type +gsinfo+) (setf (sessionuuid s) (readgsstring (strm s))) type) + ((= type +gsfail+) (make-instance 'failmsg)) + ((= type +gsok+) (make-instance 'okmsg)) + ((= type +gsrualive+) (writemsg s (make-instance 'imalivemsg))) ; automatically respond to rualive + ((= type +gsimalive+) (make-instance 'imalivemsg)) + ((= type +gsgr+) (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) + ((= type +gsgm+) (make-instance 'geommanifestreq :manifest (loop for i from 0 to (readuint32 (strm s)) collect (readgsstring (strm s))))) + ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk (let ((len (readuint32 (strm s)))) (loop with c = (make-array len :element-type '(unsigned-byte 8)) for i from 0 to len do (setf (aref c i) (read-byte (strm s))))))) + (t (format t "Unknown type! ~x~%" type)))) + '())) + +(defgeneric writemsg (session message) (:documentation "Send the message to the socket stream")) + +;;; common to all messages +(defmethod writemsg :before (s (m message)) (setf (len m) (+ (len m) 7 (length (uuid m)) (if (reuuid m) (+ (length (reuuid m)) 4) 0) ))) +(defmethod writemsg (s (m message)) + (writeuint32 (strm s) +magic+) + (writeuint32 (strm s) (len m)) + (writeuint16 (strm s) (msgtype m)) + (writegsstring (strm s) (uuid m)) + (if (reuuid m) + (progn (write-byte 1 (strm s)) (writegsstring (strm s) (reuuid m))) + (write-byte 0 (strm s)))) +(defmethod writemsg :around (s (m message)) (call-next-method) (force-output (strm s))) + +;;; type specific send handling +(defclass pingmsg (message) ((tv :accessor tv :initform (usec)))) +(defmethod writemsg :before (s (m pingmsg)) (setf (msgtype m) +gsping+) (setf (len m) 8)) +(defmethod writemsg :after (s (m pingmsg)) (format t "Pinging with ~a~%" (tv m)) (writeuint64 (strm s) (tv m))) + +(defclass pongmsg (message) ((tv :accessor tv :initarg :tv))) +(defmethod writemsg :before (s (m pongmsg)) (setf (msgtype m) +gspong+) (setf (len m) 8)) +(defmethod writemsg :after (s (m pongmsg)) (writeuint64 (strm s) (tv m))) + +(defclass nodenamemsg (message) ((name :accessor name :initarg :name))) +(defmethod writemsg :before (s (m nodenamemsg)) (setf (msgtype m) +gsrnnset+) (setf (len m) (+ (length (localnode s)) 4))) +(defmethod writemsg :after (s (m nodenamemsg)) (writegsstring (strm s) (localnode s))) + +(defclass loginmsg (message) ()) +(defmethod writemsg :before (s (m loginmsg)) (setf (msgtype m) +gsnsr+) (setf (len m) (+ (length (username s)) (length (password s)) 8))) +(defmethod writemsg :after (s (m loginmsg)) (writegsstring (strm s) (username s)) (writegsstring (strm s) (password s))) + +(defclass logoutmsg (message) ()) +(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsdr+)) + +(defclass rualivemsg (message) ()) +(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsrualive+)) + +(defclass imalivemsg (message) ()) +(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsimalive+)) + +(defclass okmsg (message) ()) +(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsok+)) + +(defclass failmsg (message) ()) +(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsfail+)) + +(defclass geomreqmsg (message) ((uri :accessor uri :initarg :uri :initform ""))) +(defmethod writemsg :before (s (m geomreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) +(defmethod writemsg :after (s (m geomreqmsg)) (writegsstring (strm s) (uri m))) + +(defclass geommanifestmsg (message) ((manifest :accessor manifest :initarg :manifest))) +(defmethod writemsg :before (s (m geommanifestmsg)) + (setf (msgtype m) +gsgm+) + (setf (len m) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))))) +(defmethod writemsg :after (s (m geomreqmsg)) (writeuint32 (strm s) (length (manifest m))) + (loop for i in (manifest m) do (writegsstring (strm s) i))) + +(defclass geomchunkmsg (message) ((chunk :accessor chunk :initarg :chunk))) +(defmethod writemsg :before (s (m geomchunkmsg)) (setf (msgtype m) +gsgc+) (setf (len m) (length (chunk m)))) +(defmethod writemsg :after (s (m geomchunkmsg)) (writeuint32 (strm s) (length (chunk m))) (loop for i from 0 to (length (chunk m)) do (write-byte (aref (chunk m) i) (strm s)))) + Property changes on: geomcore/trunk/src/interfaces/cl/gsnet.lisp ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-03-31 20:07:54
|
Revision: 44138 http://brlcad.svn.sourceforge.net/brlcad/?rev=44138&view=rev Author: erikgreenwald Date: 2011-03-31 20:07:47 +0000 (Thu, 31 Mar 2011) Log Message: ----------- basic server Added Paths: ----------- geomcore/trunk/src/interfaces/cl/gsserver.asd geomcore/trunk/src/interfaces/cl/gsserver.lisp Added: geomcore/trunk/src/interfaces/cl/gsserver.asd =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.asd (rev 0) +++ geomcore/trunk/src/interfaces/cl/gsserver.asd 2011-03-31 20:07:47 UTC (rev 44138) @@ -0,0 +1,14 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(asdf:defsystem gsserver + :name "gsserver" + :version "0.0.0" + :maintainer "Erik G" + :author "Erik G" + :licence "BSD sans advertising clause (see file COPYING for details)" + :description "GeometryService server" + :long-description "Common Lisp server for the BRL-CAD Geometry Service protocol" + :depends-on (:cffi :usocket :uuid) + :components ((:file "gsnet") + (:file "gsserver"))) + Property changes on: geomcore/trunk/src/interfaces/cl/gsserver.asd ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native Added: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp (rev 0) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-03-31 20:07:47 UTC (rev 44138) @@ -0,0 +1,51 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(in-package :cl-user) + +(defpackage :gsserver + (:use :cl :sb-unix) + (:export :run)) + +(in-package :gsserver) + +(defparameter +nodename+ "Spokelse") + +(defun authenticate (s user pass) + (setf (gsnet::username s) user) + (setf (gsnet::password s) pass) + (and (string= user "Guest") (string= pass "Guest"))) + +(defun send-geom (s reuuid filename) + ;; read file into buffer + ;; (writemsg s (make-instance 'gsnet:geommanifestmsg :manifest (list filename))) + ;; (writemsg s (make-instance 'gsnet:geomchunkmsg :chunk buffer)) + t) + +(defun handle-connection (st) + (let ((s (make-instance 'gsnet:session :stream st))) + + ;;; initial handshane and authentication + (setf (gsnet::localnode s) +nodename+) + (gsnet:writemsg s (make-instance 'gsnet:nodenamemsg :name +nodename+)) + (if (not (gsnet:readmsg s)) (return-from handle-connection '())) + (let ((m (gsnet:readmsg s))) + (if (equalp (type-of m) 'gsnet:loginmsg) + (if (not (authenticate s (gsnet::username m) (gsnet::password m))) (return-from handle-connection '())) + (return-from handle-connection '()))) + (gsnet:writemsg s (make-instance 'gsnet::okmsg)) + + ;;; main loop + (loop do + (let ((m (gsnet:readmsg s))) + (cond + ((equalp (type-of m) 'geomreqmsg) (send-geom s (gsnet::uuid m) (gsnet::name m))) + ((equalp m t) '()) + ((equalp m '()) (return-from handle-connection)) + (t (format t "Unhandled thing ~a~%" (type-of m)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; public interface ;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun run (&key (listenhost #(127 0 0 1)) (port 5309)) + (usocket:socket-server listenhost port #'handle-connection '() :element-type 'unsigned-byte)) Property changes on: geomcore/trunk/src/interfaces/cl/gsserver.lisp ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-04 14:52:07
|
Revision: 44183 http://brlcad.svn.sourceforge.net/brlcad/?rev=44183&view=rev Author: erikgreenwald Date: 2011-04-04 14:52:00 +0000 (Mon, 04 Apr 2011) Log Message: ----------- add geombotreqmsg Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.lisp geomcore/trunk/src/interfaces/cl/gsnet.lisp geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 14:45:12 UTC (rev 44182) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 14:52:00 UTC (rev 44183) @@ -12,13 +12,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this should probably check to make sure things are ok -(defun getgeom (s st uri) - (gsnet:writemsg s (make-instance 'gsnet:geomreqmsg :uri uri)) +(defun getgeom (s st uri &key (bot '())) + (gsnet:writemsg s (make-instance (if bot 'gsnet:geombotreqmsg 'gsnet:geomreqmsg) :uri uri)) (loop for i from 0 to (length (gsnet::manifest (gsnet:readmsg s))) do (write-sequence (gsnet::chunk (gsnet:readmsg s)) st))) -(defun getgeomfile (s file uri) +(defun getgeomfile (s file uri &key (bot '())) (with-open-file (out file :element-type '(unsigned-byte 8) :direction :output) - (getgeom s out uri))) + (getgeom s out uri :bot bot))) (defun ping (s) (gsnet:writemsg s (make-instance 'gsnet:pingmsg)) Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 14:45:12 UTC (rev 44182) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 14:52:00 UTC (rev 44183) @@ -4,7 +4,7 @@ (defpackage :gsnet (:use :cl :sb-unix) (:export :connect :writemsg :readmsg - :session :message :pingmsg :pongmsg :nodenamemsg :loginmsg :logoutmsg :rualivemsg :imalivemsg :okmsg :failmsg :geomreqmsg :geommanifestmsg :geomchunkmsg + :session :message :pingmsg :pongmsg :nodenamemsg :loginmsg :logoutmsg :rualivemsg :imalivemsg :okmsg :failmsg :geomreqmsg :geombotreqmsg :geommanifestmsg :geomchunkmsg :manifest :remotenode :sessionuuid :socket :strm :usec)) @@ -28,6 +28,7 @@ (defconstant +gsnsr+ #x0300) ; New Session Request (defconstant +gsinfo+ #x0305) ; Session Information (defconstant +gsgr+ #x0400) ; Geometry Request +(defconstant +gsgbr+ #x0401) ; Geometry BoT Request (defconstant +gsgm+ #x0405) ; Geometry Manifest (defconstant +gsgc+ #x0410) ; Geometry Chunk @@ -90,6 +91,7 @@ ((= type +gsrualive+) (writemsg s (make-instance 'imalivemsg)) t) ; automatically respond to rualive ((= type +gsimalive+) (make-instance 'imalivemsg)) ((= type +gsgr+) (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) + ((= type +gsgbr+) (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) ((= type +gsgm+) (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) @@ -153,6 +155,10 @@ (defmethod writemsg :before (s (m geomreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) (defmethod writemsg :after (s (m geomreqmsg)) (writegsstring (strm s) (uri m))) +(defclass geombotreqmsg (message) ((uri :accessor uri :initarg :uri :initform ""))) +(defmethod writemsg :before (s (m geombotreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) +(defmethod writemsg :after (s (m geombotreqmsg)) (writegsstring (strm s) (uri m))) + (defclass geommanifestmsg (message) ((manifest :accessor manifest :initarg :manifest))) (defmethod writemsg :before (s (m geommanifestmsg)) (setf (msgtype m) +gsgm+) (setf (len m) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))))) (defmethod writemsg :after (s (m geommanifestmsg)) (writeuint32 (strm s) (length (manifest m))) (loop for i in (manifest m) do (writegsstring (strm s) i))) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-04 14:45:12 UTC (rev 44182) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-04 14:52:00 UTC (rev 44183) @@ -21,6 +21,9 @@ (read-sequence arr stream) (gsnet:writemsg s (make-instance 'gsnet:geomchunkmsg :chunk arr :reuuid reuuid))))) +(defun send-bot-geom (s reuuid filename) + (gsnet:writemsg s (make-instance 'gsnet:failmsg))) + (defun handle-connection (st) (let ((s (make-instance 'gsnet:session :stream st))) @@ -40,6 +43,7 @@ (let ((m (gsnet:readmsg s))) (cond ((equalp (type-of m) 'gsnet:geomreqmsg) (send-geom s (gsnet::uuid m) (gsnet::uri m))) + ((equalp (type-of m) 'gsnet:geombotreqmsg) (send-bot-geom s (gsnet::uuid m) (gsnet::uri m))) ((equalp m t) '()) ((equalp m '()) (return-from handle-connection)) (t (format t "Unhandled thing ~a~%" (type-of m)))))))) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-04 17:56:08
|
Revision: 44186 http://brlcad.svn.sourceforge.net/brlcad/?rev=44186&view=rev Author: erikgreenwald Date: 2011-04-04 17:56:01 +0000 (Mon, 04 Apr 2011) Log Message: ----------- fix off by one weirdness in chunk request Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.lisp geomcore/trunk/src/interfaces/cl/gsnet.lisp geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 17:03:41 UTC (rev 44185) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 17:56:01 UTC (rev 44186) @@ -3,7 +3,7 @@ (defpackage :gsclient (:use :cl :sb-unix) - (:export :login :logout :ping :getgeom)) + (:export :login :logout :ping :getgeom :getgeomfile)) (in-package :gsclient) @@ -14,7 +14,7 @@ ;; this should probably check to make sure things are ok (defun getgeom (s st uri &key (bot '())) (gsnet:writemsg s (make-instance (if bot 'gsnet:geombotreqmsg 'gsnet:geomreqmsg) :uri uri)) - (loop for i from 0 to (length (gsnet::manifest (gsnet:readmsg s))) do (write-sequence (gsnet::chunk (gsnet:readmsg s)) st))) + (loop for i from 1 to (length (gsnet::manifest (gsnet:readmsg s))) do (write-sequence (gsnet::chunk (gsnet:readmsg s)) st :end (- (length ch) 1)))) (defun getgeomfile (s file uri &key (bot '())) (with-open-file (out file :element-type '(unsigned-byte 8) :direction :output) Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 17:03:41 UTC (rev 44185) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 17:56:01 UTC (rev 44186) @@ -94,9 +94,9 @@ ((= type +gsgbr+) (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) ((= type +gsgm+) (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk - (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) - (read-sequence arr (strm s)) - arr))) + (let ((arr (make-array (+ (readuint32 (strm s) 1) :element-type '(unsigned-byte 8)))) + (read-sequence arr (strm s)) + arr)))) ((= type +gsnsr+) (make-instance 'loginmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) (t (format t "Unknown type! ~x~%" type)))) '())) @@ -165,4 +165,4 @@ (defclass geomchunkmsg (message) ((chunk :accessor chunk :initarg :chunk))) (defmethod writemsg :before (s (m geomchunkmsg)) (setf (msgtype m) +gsgc+) (setf (len m) (length (chunk m)))) -(defmethod writemsg :after (s (m geomchunkmsg)) (writeuint32 (strm s) (length (chunk m))) (write-sequence (chunk m) (strm s))) +(defmethod writemsg :after (s (m geomchunkmsg)) (writeuint32 (strm s) (- (length (chunk m)) 1)) (write-sequence (chunk m) (strm s))) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-04 17:03:41 UTC (rev 44185) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-04 17:56:01 UTC (rev 44186) @@ -17,8 +17,8 @@ (defun send-geom (s reuuid filename) (gsnet:writemsg s (make-instance 'gsnet:geommanifestmsg :manifest (list filename))) - (with-open-file (stream (concatenate +dbdir+ filename) :element-type '(unsigned-byte 8) :if-does-not-exist :error) - (let ((arr (make-array (file-length stream) :element-type '(unsigned-byte 8)))) + (with-open-file (stream (concatenate 'string +dbdir+ filename) :element-type '(unsigned-byte 8) :if-does-not-exist :error) + (let ((arr (make-array (+ (file-length stream) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr stream) (gsnet:writemsg s (make-instance 'gsnet:geomchunkmsg :chunk arr :reuuid reuuid))))) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-04 18:04:47
|
Revision: 44188 http://brlcad.svn.sourceforge.net/brlcad/?rev=44188&view=rev Author: erikgreenwald Date: 2011-04-04 18:04:41 +0000 (Mon, 04 Apr 2011) Log Message: ----------- fix malformed expressions Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.lisp geomcore/trunk/src/interfaces/cl/gsnet.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 18:04:07 UTC (rev 44187) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-04 18:04:41 UTC (rev 44188) @@ -14,7 +14,7 @@ ;; this should probably check to make sure things are ok (defun getgeom (s st uri &key (bot '())) (gsnet:writemsg s (make-instance (if bot 'gsnet:geombotreqmsg 'gsnet:geomreqmsg) :uri uri)) - (loop for i from 1 to (length (gsnet::manifest (gsnet:readmsg s))) do (write-sequence (gsnet::chunk (gsnet:readmsg s)) st :end (- (length ch) 1)))) + (loop for i from 1 to (length (gsnet::manifest (gsnet:readmsg s))) do (let ((ch (gsnet::chunk (gsnet:readmsg s)))) (write-sequence ch st :end (- (length ch) 1))))) (defun getgeomfile (s file uri &key (bot '())) (with-open-file (out file :element-type '(unsigned-byte 8) :direction :output) Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 18:04:07 UTC (rev 44187) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-04 18:04:41 UTC (rev 44188) @@ -94,9 +94,9 @@ ((= type +gsgbr+) (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) ((= type +gsgm+) (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk - (let ((arr (make-array (+ (readuint32 (strm s) 1) :element-type '(unsigned-byte 8)))) + (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr (strm s)) - arr)))) + arr))) ((= type +gsnsr+) (make-instance 'loginmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) (t (format t "Unknown type! ~x~%" type)))) '())) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-04 20:37:10
|
Revision: 44196 http://brlcad.svn.sourceforge.net/brlcad/?rev=44196&view=rev Author: erikgreenwald Date: 2011-04-04 20:37:04 +0000 (Mon, 04 Apr 2011) Log Message: ----------- start up a cffi wrapper for librt Added Paths: ----------- geomcore/trunk/src/interfaces/cl/brlcad.asd geomcore/trunk/src/interfaces/cl/brlcad.lisp Added: geomcore/trunk/src/interfaces/cl/brlcad.asd =================================================================== --- geomcore/trunk/src/interfaces/cl/brlcad.asd (rev 0) +++ geomcore/trunk/src/interfaces/cl/brlcad.asd 2011-04-04 20:37:04 UTC (rev 44196) @@ -0,0 +1,14 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(asdf:defsystem brlcad + :name "brlcad" + :version "0.0.0" + :maintainer "Erik G" + :author "Erik G" + :licence "BSD sans advertising clause (see file COPYING for details)" + :description "GeometryService client" + :long-description "Common Lisp client interface for the BRL-CAD Geometry Service protocol" + :serial t + :depends-on (:cffi) + :components ((:file "brlcad"))) + Property changes on: geomcore/trunk/src/interfaces/cl/brlcad.asd ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn::eol-style + native Added: svn:eol-style + native Added: geomcore/trunk/src/interfaces/cl/brlcad.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/brlcad.lisp (rev 0) +++ geomcore/trunk/src/interfaces/cl/brlcad.lisp 2011-04-04 20:37:04 UTC (rev 44196) @@ -0,0 +1,112 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(in-package :cl-user) + +(defpackage :brlcad + (:use :cl :cffi) + (:export :db-open)) + +(in-package :brlcad) + +(pushnew #P"/usr/brlcad/lib/" cffi:*foreign-library-directories* :test #'equal) +#+darwin(pushnew #P"/usr/brlcad/lib/" cffi:*darwin-framework-directories* :test #'equal) + +(cffi:define-foreign-library librt + (:darwin (:or "librt.19.dylib" "librt.dylib")) + (:unix (:or "librt.19.so" "librt.so")) + (:windows "librt.dll") + (t (:default "librt"))) +(cffi:use-foreign-library librt) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defcstruct xray "Ray" + (magic :uint32) + (index :int) + (r_pt :double :count 3) + (r_dir :double :count 3) + (r_min :double) + (r_man :double)) + +(defcstruct application "Application structure" + (a_magic :uint32) + + ;;; THESE ELEMENTS ARE MANDATORY + (a_ray xray) ; Actual ray to be shot + + (a_hit :pointer) + (a_miss :pointer) + + (a_onehit :int) ; flag to stop on first hit + (a_ray_length :double) ; distance from ray start to end :intersections + (a_rt_i :pointer) ; this librt instance + (a_zero1 :int) ; must be zero (sanity check) + ;;; THESE ELEMENTS ARE USED BY THE LIBRARY, BUT MAY BE LEFT ZERO + (a_resource :pointer) ; dynamic memory resources + + (a_overlap :pointer) + (a_multioverlap :pointer) + (a_logoverlap :pointer) + + (a_level :int) ; recursion level (for pr:inting) + (a_x :int) ; Screen X of ray, if applicable + (a_y :int) ; Screen Y of ray, if applicable + (a_purpose :string) ; Debug string: purpose of ray + (a_rbeam :double) ; initial beam radius (mm) + (a_diverge :double) ; slope of beam divergance/mm + (a_return :int) ; Return of a_hit()/a_miss() + (a_no_booleans :int) ; 1= partitions==segs, no booleans + (attrs :pointer) ; null terminated list of attributes This list should be the same as passed to rt_gettrees_and_attrs() + + ;;; THESE ELEMENTS ARE USED BY THE PROGRAM "rt" AND MAY BE USED BY + ;;; THE LIBRARY AT SOME FUTURE DATE + ;;; AT THIS TIME THEY MAY BE LEFT ZERO + (a_pixelext :pointer) ; locations of pixel corners + + ;;; THESE ELEMENTS ARE WRITTEN BY THE LIBRARY, AND MAY BE READ IN a_hit() + (a_finished_segs_hdp :pointer) + (a_Final_Part_hdp :pointer) + (a_inv_dir :double :count 3) ; filled in by rt_shootray(), inverse of ray direction cosines + + ;;; THE FOLLOWING ELEMENTS ARE MAINLINE & APPLICATION SPECIFIC. + ;;; THEY ARE NEVER EXAMINED BY THE LIBRARY. + (a_user :int) ; application-specific value + (a_uptr :pointer) ; application-specific pointer + (a_spectrum :pointer) + (a_color :double :count 3) ; application-specific color + (a_dist :double) ; application-specific distance + (a_uvec :double :count 3) ; application-specific vector + (a_vvec :double :count 3) ; application-specific vector + (a_refrac_index :double) ; current index of refraction + (a_cumlen :double) ; cumulative length of ray + (a_flag :int) ; application-specific flag + (a_zero2 :int)) ; must be zero (sanity check) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defcfun "db_open" :pointer (file :string) (mode :string)) +(defcfun "db_close" :void (dbip :pointer)) +(defcfun "db_dirbuild" :int (dbip :pointer)) +(defcfun "db_walk_tree" :void + (dbip :pointer) + (argc :int) + (argv :string) + (ncpu :int) + (tree_state :pointer) + (start-func :pointer) + (end-func :pointer) + (leaf-func :pointer) + (client-data :pointer)) +(defcfun "db_version" :int (dbip :pointer)) + +(defcfun "rt_dirbuild" :pointer (file :string) (descr :string) (i :int)) +(defcfun "rt_prep_parallel" :void (rti :pointer) (ncpu :int)) +(defcfun "rt_gettree" :int (rti :pointer) (reg :string)) +(defcfun "rt_free_rti" :void (rti :pointer)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun rt-open (filename regions) + (let ((a (foreign-alloc (foreign-type-size 'application)))) + (setf (application-a_rt_i a) (rt-dirbuild filename "RT" 0)) + (loop for region in regions do (rt-gettree (application-a_rt_i a) region)) + a)) Property changes on: geomcore/trunk/src/interfaces/cl/brlcad.lisp ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-05 13:34:44
|
Revision: 44205 http://brlcad.svn.sourceforge.net/brlcad/?rev=44205&view=rev Author: erikgreenwald Date: 2011-04-05 13:34:37 +0000 (Tue, 05 Apr 2011) Log Message: ----------- clean up conditional stuff Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsnet.lisp geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-05 13:34:13 UTC (rev 44204) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-05 13:34:37 UTC (rev 44205) @@ -38,7 +38,7 @@ (defun writeuint64 (s i) (loop for a in '(56 48 40 32 24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) (defun writeuint32 (s i) (loop for a in '(24 16 8 0) do (write-byte (ldb (byte 8 a) i) s))) (defun writeuint16 (s i) (loop for a in '(8 0) do (write-byte (ldb (byte 8 a) i) s))) -(defun writegsstring (s str) (writeuint32 s (length str)) (loop for x being the element of str do (if x (write-byte (char-code x) s)))) +(defun writegsstring (s str) (writeuint32 s (length str)) (loop for x being the element of str do (when x (write-byte (char-code x) s)))) ;;; utility functions to read in (defun readuint64 (s) (apply #'+ (loop for a in '(56 48 40 32 24 16 8 0) collect (dpb (read-byte s) (byte 8 a) 0)))) @@ -72,33 +72,33 @@ ;;; snarf data off the line and return an instance of the right kind of class (defun readmsg (s) - (if (readmagic (strm s)) + (when (readmagic (strm s)) (let ((length (readuint32 (strm s))) (type (readuint16 (strm s))) (uuid (readgsstring (strm s))) - (reuuid (if (= (read-byte (strm s)) 1) (readuuid (strm s)) '()))) + (reuuid (when (= (read-byte (strm s)) 1) (readuuid (strm s)) '()))) (declare (ignore length)) (declare (ignore uuid)) (declare (ignore reuuid)) - (cond - ((= type +gsrnnset+) (setf (remotenode s) (readgsstring (strm s))) t) - ((= type +gsdr+) (writemsg s (make-instance 'logoutmsg)) '()) - ((= type +gspong+) (make-instance 'pongmsg :tv (readuint64 (strm s)))) - ((= type +gsping+) (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s)))) t) ; automatically respond to ping requests - ((= type +gsinfo+) (setf (sessionuuid s) (readgsstring (strm s))) t) - ((= type +gsfail+) (make-instance 'failmsg)) - ((= type +gsok+) (make-instance 'okmsg)) - ((= type +gsrualive+) (writemsg s (make-instance 'imalivemsg)) t) ; automatically respond to rualive - ((= type +gsimalive+) (make-instance 'imalivemsg)) - ((= type +gsgr+) (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) - ((= type +gsgbr+) (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) - ((= type +gsgm+) (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) - ((= type +gsgc+) (make-instance 'geomchunkmsg :chunk - (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) + (case type + (+gsrnnset+ (setf (remotenode s) (readgsstring (strm s))) t) + (+gsdr+ (writemsg s (make-instance 'logoutmsg)) '()) + (+gspong+ (make-instance 'pongmsg :tv (readuint64 (strm s)))) + (+gsping+ (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s)))) t) ; automatically respond to ping requests + (+gsinfo+ (setf (sessionuuid s) (readgsstring (strm s))) t) + (+gsfail+ (make-instance 'failmsg)) + (+gsok+ (make-instance 'okmsg)) + (+gsrualive+ (writemsg s (make-instance 'imalivemsg)) t) ; automatically respond to rualive + (+gsimalive+ (make-instance 'imalivemsg)) + (+gsgr+ (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) + (+gsgbr+ (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) + (+gsgm+ (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) + (+gsgc+ (make-instance 'geomchunkmsg :chunk + (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr (strm s)) arr))) - ((= type +gsnsr+) (make-instance 'loginmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) - (t (format t "Unknown type! ~x~%" type)))) + (+gsnsr+ (make-instance 'loginmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) + (otherwise (format t "Unknown type! ~x~%" type)))) '())) (defgeneric writemsg (session message) (:documentation "Send the message to the socket stream")) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-05 13:34:13 UTC (rev 44204) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-05 13:34:37 UTC (rev 44205) @@ -40,10 +40,10 @@ (setf (gsnet::sessionuuid s) (format '() "~a" (uuid:make-v4-uuid))) (setf (gsnet::localnode s) +nodename+) (gsnet:writemsg s (make-instance 'gsnet:nodenamemsg :name +nodename+)) - (if (not (gsnet:readmsg s)) (return-from handle-connection '())) + (unless (gsnet:readmsg s) (return-from handle-connection '())) (let ((m (gsnet:readmsg s))) (if (equalp (type-of m) 'gsnet:loginmsg) - (if (not (authenticate s (gsnet::username m) (gsnet::password m))) (return-from handle-connection '())) + (unless (authenticate s (gsnet::username m) (gsnet::password m)) (return-from handle-connection '())) (return-from handle-connection '()))) (gsnet:writemsg s (make-instance 'gsnet::infomsg :sessionuuid (gsnet::sessionuuid s))) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-05 20:50:39
|
Revision: 44235 http://brlcad.svn.sourceforge.net/brlcad/?rev=44235&view=rev Author: erikgreenwald Date: 2011-04-05 20:50:32 +0000 (Tue, 05 Apr 2011) Log Message: ----------- macros! Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.lisp geomcore/trunk/src/interfaces/cl/gsnet.lisp geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-05 20:43:47 UTC (rev 44234) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-05 20:50:32 UTC (rev 44235) @@ -13,7 +13,7 @@ ;; this should probably check to make sure things are ok (defun getgeom (s st uri &key (bot '())) - (gsnet:writemsg s (make-instance (if bot 'gsnet:geombotreqmsg 'gsnet:geomreqmsg) :uri uri)) + (gsnet:writemsg s (make-instance (if bot 'gsnet:gbrmsg 'gsnet:grmsg) :uri uri)) (loop for i from 1 to (length (gsnet::manifest (gsnet:readmsg s))) do (let ((ch (gsnet::chunk (gsnet:readmsg s)))) (write-sequence ch st :end (- (length ch) 1))))) (defun getgeomfile (s file uri &key (bot '())) @@ -30,12 +30,12 @@ (let ((s (make-instance 'gsnet:session :host host :port port :username username :password password))) (setf (gsnet::socket s) (usocket:socket-connect host port :element-type '(unsigned-byte 8))) (setf (gsnet::strm s) (usocket:socket-stream (gsnet:socket s))) - (gsnet:writemsg s (make-instance 'gsnet:nodenamemsg :name (gsnet::localnode s))) + (gsnet:writemsg s (make-instance 'gsnet:rnnsetmsg :name (gsnet::localnode s))) (gsnet:readmsg s) - (gsnet:writemsg s (make-instance 'gsnet:loginmsg)) + (gsnet:writemsg s (make-instance 'gsnet:nsrmsg)) (gsnet:readmsg s) s)) (defun logout (s) - (gsnet:writemsg s (make-instance 'gsnet:logoutmsg)) + (gsnet:writemsg s (make-instance 'gsnet:drmsg)) (usocket:socket-close (gsnet:socket s))) Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-05 20:43:47 UTC (rev 44234) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-05 20:50:32 UTC (rev 44235) @@ -4,7 +4,8 @@ (defpackage :gsnet (:use :cl :sb-unix) (:export :connect :writemsg :readmsg - :session :message :pingmsg :pongmsg :nodenamemsg :loginmsg :logoutmsg :rualivemsg :imalivemsg :okmsg :failmsg :geomreqmsg :geombotreqmsg :geommanifestmsg :geomchunkmsg + :session :message + :pingmsg :pongmsg :rnnsetmsg :nsrmsg :drmsg :rualivemsg :imalivemsg :okmsg :failmsg :grmsg :gbrmsg :gmmsg :gcmsg :manifest :remotenode :sessionuuid :socket :strm :usec)) @@ -72,7 +73,7 @@ ;;; snarf data off the line and return an instance of the right kind of class (defun readmsg (s) - (when (readmagic (strm s)) + (if (readmagic (strm s)) (let ((length (readuint32 (strm s))) (type (readuint16 (strm s))) (uuid (readgsstring (strm s))) @@ -80,25 +81,25 @@ (declare (ignore length)) (declare (ignore uuid)) (declare (ignore reuuid)) - (case type - (+gsrnnset+ (setf (remotenode s) (readgsstring (strm s))) t) - (+gsdr+ (writemsg s (make-instance 'logoutmsg)) '()) - (+gspong+ (make-instance 'pongmsg :tv (readuint64 (strm s)))) - (+gsping+ (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s)))) t) ; automatically respond to ping requests - (+gsinfo+ (setf (sessionuuid s) (readgsstring (strm s))) t) - (+gsfail+ (make-instance 'failmsg)) - (+gsok+ (make-instance 'okmsg)) - (+gsrualive+ (writemsg s (make-instance 'imalivemsg)) t) ; automatically respond to rualive - (+gsimalive+ (make-instance 'imalivemsg)) - (+gsgr+ (make-instance 'geomreqmsg :uri (readgsstring (strm s)))) - (+gsgbr+ (make-instance 'geombotreqmsg :uri (readgsstring (strm s)))) - (+gsgm+ (make-instance 'geommanifestmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) - (+gsgc+ (make-instance 'geomchunkmsg :chunk + (cond + ((= type +gsrnnset+) (setf (remotenode s) (readgsstring (strm s))) t) + ((= type +gsdr+) (writemsg s (make-instance 'logoutmsg)) '()) + ((= type +gspong+) (make-instance 'pongmsg :tv (readuint64 (strm s)))) + ((= type +gsping+) (writemsg s (make-instance 'pongmsg :tv (readuint64 (strm s)))) t) ; automatically respond to ping requests + ((= type +gsinfo+) (setf (sessionuuid s) (readgsstring (strm s))) t) + ((= type +gsfail+) (make-instance 'failmsg)) + ((= type +gsok+) (make-instance 'okmsg)) + ((= type +gsrualive+) (writemsg s (make-instance 'imalivemsg)) t) ; automatically respond to rualive + ((= type +gsimalive+) (make-instance 'imalivemsg)) + ((= type +gsgr+) (make-instance 'grmsg :uri (readgsstring (strm s)))) + ((= type +gsgbr+) (make-instance 'gbrmsg :uri (readgsstring (strm s)))) + ((= type +gsgm+) (make-instance 'gmmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) + ((= type +gsgc+) (make-instance 'gcmsg :chunk (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr (strm s)) arr))) - (+gsnsr+ (make-instance 'loginmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) - (otherwise (format t "Unknown type! ~x~%" type)))) + ((= type +gsnsr+) (make-instance 'nsrmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) + (t (format t "Unknown type! ~a ~x~%" (type-of type) type)))) '())) (defgeneric writemsg (session message) (:documentation "Send the message to the socket stream")) @@ -116,53 +117,27 @@ (defmethod writemsg :around (s (m message)) (call-next-method) (force-output (strm s))) ;;; type specific send handling -(defclass pingmsg (message) ((tv :accessor tv :initform (usec)))) -(defmethod writemsg :before (s (m pingmsg)) (setf (msgtype m) +gsping+) (setf (len m) 8)) -(defmethod writemsg :after (s (m pingmsg)) (writeuint64 (strm s) (tv m))) -(defclass pongmsg (message) ((tv :accessor tv :initarg :tv))) -(defmethod writemsg :before (s (m pongmsg)) (setf (msgtype m) +gspong+) (setf (len m) 8)) -(defmethod writemsg :after (s (m pongmsg)) (writeuint64 (strm s) (tv m))) +(defmacro msg (name def size &optional send) + (let ((classname (intern (format nil "~:@(~amsg~)" name))) + (typename (intern (format nil "~:@(+gs~a+~)" name)))) + `(progn + (defclass ,classname (message) ,def) + (defmethod writemsg :before (s (m ,classname)) (setf (msgtype m) ,typename) (setf (len m) ,size)) + (defmethod writemsg :after (s (m ,classname)) ,send)))) -(defclass nodenamemsg (message) ((name :accessor name :initarg :name))) -(defmethod writemsg :before (s (m nodenamemsg)) (setf (msgtype m) +gsrnnset+) (setf (len m) (+ (length (localnode s)) 4))) -(defmethod writemsg :after (s (m nodenamemsg)) (writegsstring (strm s) (localnode s))) - -(defclass loginmsg (message) ((username :accessor username :initarg :username) (password :accessor password :initarg :password))) -(defmethod writemsg :before (s (m loginmsg)) (setf (msgtype m) +gsnsr+) (setf (len m) (+ (length (username s)) (length (password s)) 8))) -(defmethod writemsg :after (s (m loginmsg)) (writegsstring (strm s) (username s)) (writegsstring (strm s) (password s))) - -(defclass logoutmsg (message) ()) -(defmethod writemsg :before (s (m logoutmsg)) (setf (msgtype m) +gsdr+)) - -(defclass infomsg (message) ((sessionuuid :accessor sessionuuid :initarg :sessionuuid))) -(defmethod writemsg :before (s (m infomsg)) (setf (msgtype m) +gsinfo+) (setf (len m) (+ (length (sessionuuid m)) 4))) -(defmethod writemsg :after (s (m infomsg)) (writegsstring (strm s) (sessionuuid m))) - -(defclass rualivemsg (message) ()) -(defmethod writemsg :before (s (m rualivemsg)) (setf (msgtype m) +gsrualive+)) - -(defclass imalivemsg (message) ()) -(defmethod writemsg :before (s (m imalivemsg)) (setf (msgtype m) +gsimalive+)) - -(defclass okmsg (message) ()) -(defmethod writemsg :before (s (m okmsg)) (setf (msgtype m) +gsok+)) - -(defclass failmsg (message) ()) -(defmethod writemsg :before (s (m failmsg)) (setf (msgtype m) +gsfail+)) - -(defclass geomreqmsg (message) ((uri :accessor uri :initarg :uri :initform ""))) -(defmethod writemsg :before (s (m geomreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) -(defmethod writemsg :after (s (m geomreqmsg)) (writegsstring (strm s) (uri m))) - -(defclass geombotreqmsg (message) ((uri :accessor uri :initarg :uri :initform ""))) -(defmethod writemsg :before (s (m geombotreqmsg)) (setf (msgtype m) +gsgr+) (setf (len m) (+ (length (uri m)) 4))) -(defmethod writemsg :after (s (m geombotreqmsg)) (writegsstring (strm s) (uri m))) - -(defclass geommanifestmsg (message) ((manifest :accessor manifest :initarg :manifest))) -(defmethod writemsg :before (s (m geommanifestmsg)) (setf (msgtype m) +gsgm+) (setf (len m) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))))) -(defmethod writemsg :after (s (m geommanifestmsg)) (writeuint32 (strm s) (length (manifest m))) (loop for i in (manifest m) do (writegsstring (strm s) i))) - -(defclass geomchunkmsg (message) ((chunk :accessor chunk :initarg :chunk))) -(defmethod writemsg :before (s (m geomchunkmsg)) (setf (msgtype m) +gsgc+) (setf (len m) (length (chunk m)))) -(defmethod writemsg :after (s (m geomchunkmsg)) (writeuint32 (strm s) (- (length (chunk m)) 1)) (write-sequence (chunk m) (strm s))) +(msg ping ((tv :accessor tv :initform (usec))) 8 (writeuint64 (strm s) (tv m))) +(msg pong ((tv :accessor tv :initarg :tv)) 8 (writeuint64 (strm s) (tv m))) +(msg rnnset ((name :accessor name :initarg :name)) (+ (length (localnode s)) 4) (writegsstring (strm s) (localnode s))) +(msg nsr ((username :accessor username :initarg :username) (password :accessor password :initarg :password)) + (+ (length (username s)) (length (password s)) 8) (progn (writegsstring (strm s) (username s)) (writegsstring (strm s) (password s)))) +(msg dr () 0) +(msg info ((sessionuuid :accessor sessionuuid :initarg :sessionuuid)) (+ (length (sessionuuid m)) 4) (writegsstring (strm s) (sessionuuid m))) +(msg rualive () 0) +(msg imalive () 0) +(msg ok () 0) +(msg fail () 0) +(msg gr ((uri :accessor uri :initarg :uri :initform "")) (+ (length (uri m)) 4) (writegsstring (strm s) (uri m))) +(msg gbr ((uri :accessor uri :initarg :uri :initform "")) (+ (length (uri m)) 4) (writegsstring (strm s) (uri m))) +(msg gm ((manifest :accessor manifest :initarg :manifest)) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))) (progn (writeuint32 (strm s) (length (manifest m))) (loop for i in (manifest m) do (writegsstring (strm s) i)))) +(msg gc ((chunk :accessor chunk :initarg :chunk)) (+ (length (chunk m)) 4) (progn (writeuint32 (strm s) (- (length (chunk m)) 1)) (write-sequence (chunk m) (strm s)))) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-05 20:43:47 UTC (rev 44234) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-05 20:50:32 UTC (rev 44235) @@ -16,19 +16,19 @@ (and (string= user "Guest") (string= pass "Guest"))) (defun send-geom (s reuuid filename) - (gsnet:writemsg s (make-instance 'gsnet:geommanifestmsg :manifest (list filename))) + (gsnet:writemsg s (make-instance 'gsnet:gmmsg :manifest (list filename))) (with-open-file (stream (concatenate 'string +dbdir+ filename) :element-type '(unsigned-byte 8) :if-does-not-exist :error) (let ((arr (make-array (+ (file-length stream) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr stream) - (gsnet:writemsg s (make-instance 'gsnet:geomchunkmsg :chunk arr :reuuid reuuid))))) + (gsnet:writemsg s (make-instance 'gsnet:gcmsg :chunk arr :reuuid reuuid))))) (defun send-bot-geom (s reuuid filename) (gsnet:writemsg s (make-instance 'gsnet:failmsg))) (defun handle-packet (s m) (cond - ((equalp (type-of m) 'gsnet:geomreqmsg) (send-geom s (gsnet::uuid m) (gsnet::uri m))) - ((equalp (type-of m) 'gsnet:geombotreqmsg) (send-bot-geom s (gsnet::uuid m) (gsnet::uri m))) + ((equalp (type-of m) 'gsnet:grmsg) (send-geom s (gsnet::uuid m) (gsnet::uri m))) + ((equalp (type-of m) 'gsnet:gbrmsg) (send-bot-geom s (gsnet::uuid m) (gsnet::uri m))) ((equalp m t) m) ((equalp m '()) m) (t (format t "Unhandled thing ~a~%" (type-of m))))) @@ -39,10 +39,10 @@ ;;; initial handshane and authentication (setf (gsnet::sessionuuid s) (format '() "~a" (uuid:make-v4-uuid))) (setf (gsnet::localnode s) +nodename+) - (gsnet:writemsg s (make-instance 'gsnet:nodenamemsg :name +nodename+)) + (gsnet:writemsg s (make-instance 'gsnet:rnnsetmsg :name +nodename+)) (unless (gsnet:readmsg s) (return-from handle-connection '())) (let ((m (gsnet:readmsg s))) - (if (equalp (type-of m) 'gsnet:loginmsg) + (if (equalp (type-of m) 'gsnet:nsrmsg) (unless (authenticate s (gsnet::username m) (gsnet::password m)) (return-from handle-connection '())) (return-from handle-connection '()))) (gsnet:writemsg s (make-instance 'gsnet::infomsg :sessionuuid (gsnet::sessionuuid s))) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-12 15:16:39
|
Revision: 44317 http://brlcad.svn.sourceforge.net/brlcad/?rev=44317&view=rev Author: erikgreenwald Date: 2011-04-12 15:16:32 +0000 (Tue, 12 Apr 2011) Log Message: ----------- libgvm cffi Added Paths: ----------- geomcore/trunk/src/interfaces/cl/gvm.asd geomcore/trunk/src/interfaces/cl/gvm.lisp Added: geomcore/trunk/src/interfaces/cl/gvm.asd =================================================================== --- geomcore/trunk/src/interfaces/cl/gvm.asd (rev 0) +++ geomcore/trunk/src/interfaces/cl/gvm.asd 2011-04-12 15:16:32 UTC (rev 44317) @@ -0,0 +1,14 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(asdf:defsystem gvm + :name "gvm" + :version "0.0.0" + :maintainer "Erik G" + :author "Erik G" + :licence "BSD sans advertising clause (see file COPYING for details)" + :description "GeometryService version manager" + :long-description "Common Lisp client interface for the BRL-CAD Geometry Service version management stuff" + :serial t + :depends-on (:cffi) + :components ((:file "gvm"))) + Property changes on: geomcore/trunk/src/interfaces/cl/gvm.asd ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native Added: geomcore/trunk/src/interfaces/cl/gvm.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gvm.lisp (rev 0) +++ geomcore/trunk/src/interfaces/cl/gvm.lisp 2011-04-12 15:16:32 UTC (rev 44317) @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(in-package :cl-user) + +(defpackage :gvm + (:use :cl :cffi) + (:export + :gvm_info_init + :gvm_info_free + :gvm_info_clear_objects + :gvm_init_repo + :gvm_open_repo + :gvm_object_in_model + :gvm_get_extern_obj + :gvm_get_repo_obj + :gvm_diff + :gvm_add_to_list + :gvm_commit_objs + :gvm_new_model + :gvm_get_model + :gvm_get_objs + :gvm_import_g_file + :gvm_commit_g_file + :gvm_export_g_file + :gvm_export_list + :gvm_export_object)) + +(in-package :gvm) + +(pushnew #P"/usr/brlcad/lib/" cffi:*foreign-library-directories* :test #'equal) +#+darwin(pushnew #P"/usr/brlcad/lib/" cffi:*darwin-framework-directories* :test #'equal) + +(cffi:define-foreign-library libgvm + (:darwin (:or "libgvm.19.dylib" "libgvm.dylib")) + (:unix (:or "libgvm.19.so" "libgvm.so")) + (:windows "libgvm.dll") + (t (:default "libgvm"))) +(cffi:use-foreign-library libgvm) + +(defctype size_t :unsigned-int) + +(defcfun "gvm_info_init" :void (repo_info :pointer)) +(defcfun "gvm_info_free" :void (repo_info :pointer)) +(defcfun "gvm_info_clear_objects" :void (repo_info :pointer)) +(defcfun "gvm_init_repo" :int (repo_info :pointer) (repo_path :string)) +(defcfun "gvm_open_repo" :int (repo_info :pointer) (repo_path :string)) +(defcfun "gvm_object_in_model" :int (repo_info :pointer) (model_name :string) (obj_name :string) (ver_num size_t)) +(defcfun "gvm_get_extern_obj" :pointer (repo_info :pointer) (model_name :string) (obj_name :string) (ver_num size_t)) +(defcfun "gvm_get_repo_obj" :pointer (repo_info :pointer) (model_name :string) (obj_name :string) (ver_num size_t)) +(defcfun "gvm_diff" :int (repo_info :pointer) (obj1 :pointer) (obj2 :pointer)) +(defcfun "gvm_add_to_list" :int (repo_info :pointer) (obj :pointer)) +(defcfun "gvm_commit_objs" :int (repo_info :pointer)) +(defcfun "gvm_new_model" :int (repo_info :pointer) (model_name :string)) +(defcfun "gvm_get_model" :int (repo_info :pointer) (model_name :string) (ver_num size_t)) +(defcfun "gvm_get_objs" :int (repo_info :pointer) (model_name :string) (obj_name :string) (ver_num size_t) (recursive :int)) +(defcfun "gvm_import_g_file" :int (repo_info :pointer) (g_file :string)) +(defcfun "gvm_commit_g_file" :int (repo_info :pointer) (model_name :string) (g_file :string)) +(defcfun "gvm_export_g_file" :int (repo_info :pointer) (model_name :string) (g_file :string) (ver_num size_t)) +(defcfun "gvm_export_list" :int (repo_info :pointer) (model_name :string) (g_file :string)) +(defcfun "gvm_export_object" :int (repo_info :pointer) (model_name :string) (obj_name :string) (g_file :string) (ver_num size_t) (recursive :int)) Property changes on: geomcore/trunk/src/interfaces/cl/gvm.lisp ___________________________________________________________________ Added: svn:mime-type + text/plain Added: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-25 20:35:57
|
Revision: 44492 http://brlcad.svn.sourceforge.net/brlcad/?rev=44492&view=rev Author: erikgreenwald Date: 2011-04-25 20:35:51 +0000 (Mon, 25 Apr 2011) Log Message: ----------- use gvm to move files over (still entire .g file at a whack) Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsserver.asd geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsserver.asd =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.asd 2011-04-25 20:34:42 UTC (rev 44491) +++ geomcore/trunk/src/interfaces/cl/gsserver.asd 2011-04-25 20:35:51 UTC (rev 44492) @@ -9,7 +9,7 @@ :description "GeometryService server" :long-description "Common Lisp server for the BRL-CAD Geometry Service protocol" :serial t - :depends-on (:cffi :usocket :uuid) + :depends-on (:cffi :usocket :uuid :gvm :sb-posix) :components ((:file "gsnet") (:file "gsserver"))) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-25 20:34:42 UTC (rev 44491) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-25 20:35:51 UTC (rev 44492) @@ -2,12 +2,12 @@ (in-package :cl-user) (defpackage :gsserver - (:use :cl :sb-unix) + (:use :cl) (:export :run :stop)) (in-package :gsserver) -(defvar *dbdir* "/usr/brlcad/share/db/") +(defvar *dbdir* "GS_repository") (defvar *nodename* "Spokelse") (defun authenticate (s user pass) @@ -16,11 +16,16 @@ (and (string= user "Guest") (string= pass "Guest"))) (defun send-geom (s reuuid filename) - (gsnet:writemsg s (make-instance 'gsnet:gmmsg :manifest (list filename))) - (with-open-file (stream (concatenate 'string *dbdir* filename) :element-type '(unsigned-byte 8) :if-does-not-exist :error) - (let ((arr (make-array (+ (file-length stream) 1) :element-type '(unsigned-byte 8)))) - (read-sequence arr stream) - (gsnet:writemsg s (make-instance 'gsnet:gcmsg :chunk arr :reuuid reuuid))))) + (let ((repo (gvm:gvm-open *dbdir*)) + (tmpnam (sb-posix:mktemp "cltmp.XXXXX"))) + (gvm:gvm-export-g-file repo filename tmpnam gvm:+latest-version+) + (with-open-file (f tmpnam :element-type '(unsigned-byte 8) :if-does-not-exist :error) + (let ((arr (make-array (+ (file-length f) 1) :element-type '(unsigned-byte 8)))) + (gsnet:writemsg s (make-instance 'gsnet:gmmsg :manifest (list filename))) + (read-sequence arr f) + (gsnet:writemsg s (make-instance 'gsnet:gcmsg :chunk arr :reuuid reuuid)))) + (sb-posix:unlink tmpnam) + (gvm:gvm-close-repo repo))) (defun send-bot-geom (s reuuid filename) (gsnet:writemsg s (make-instance 'gsnet:failmsg))) @@ -39,7 +44,7 @@ ;;; initial handshane and authentication (setf (gsnet::sessionuuid s) (format '() "~a" (uuid:make-v4-uuid))) (setf (gsnet::localnode s) *nodename*) - (gsnet:writemsg s (make-instance 'gsnet:rnnsetmsg :name +nodename+)) + (gsnet:writemsg s (make-instance 'gsnet:rnnsetmsg :name *nodename*)) (unless (gsnet:readmsg s) (return-from handle-connection '())) (let ((m (gsnet:readmsg s))) (if (equalp (type-of m) 'gsnet:nsrmsg) @@ -54,8 +59,8 @@ ;;;;;;;;;;;;;;;;; public interface ;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun run (&key (listenhost #(127 0 0 1)) (port 5309)) - (usocket:socket-server listenhost port #'handle-connection '() :element-type 'unsigned-byte :multi-threading t :in-new-thread t)) +(defun run (&key (listenhost #(127 0 0 1)) (port 5309) (multi-threading t) (in-new-thread t)) + (usocket:socket-server listenhost port #'handle-connection '() :element-type 'unsigned-byte :multi-threading multi-threading :in-new-thread in-new-thread)) (defun stop () (map 'nil (lambda (th) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-26 16:17:44
|
Revision: 44510 http://brlcad.svn.sourceforge.net/brlcad/?rev=44510&view=rev Author: erikgreenwald Date: 2011-04-26 16:17:37 +0000 (Tue, 26 Apr 2011) Log Message: ----------- implement ls/lsr Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsclient.lisp geomcore/trunk/src/interfaces/cl/gsnet.lisp geomcore/trunk/src/interfaces/cl/gsserver.lisp Modified: geomcore/trunk/src/interfaces/cl/gsclient.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-26 15:44:32 UTC (rev 44509) +++ geomcore/trunk/src/interfaces/cl/gsclient.lisp 2011-04-26 16:17:37 UTC (rev 44510) @@ -25,6 +25,10 @@ (let ((m (gsnet:readmsg s))) (- (gsnet:usec) (gsnet::tv m)))) +(defun ls (s uri) + (gsnet:writemsg s (make-instance 'gsnet:lsmsg)) + (gsnet::manifest (gsnet:readmsg s))) + ; log in to a server, returning the session (defun login (&key (username "Guest") (password "Guest") (host #(127 0 0 1)) (port 5309)) (let ((s (make-instance 'gsnet:session :host host :port port :username username :password password))) Modified: geomcore/trunk/src/interfaces/cl/gsnet.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-26 15:44:32 UTC (rev 44509) +++ geomcore/trunk/src/interfaces/cl/gsnet.lisp 2011-04-26 16:17:37 UTC (rev 44510) @@ -5,7 +5,7 @@ (:use :cl :sb-unix) (:export :connect :writemsg :readmsg :session :message - :pingmsg :pongmsg :rnnsetmsg :nsrmsg :drmsg :rualivemsg :imalivemsg :okmsg :failmsg :grmsg :gbrmsg :gmmsg :gcmsg + :pingmsg :pongmsg :rnnsetmsg :nsrmsg :drmsg :rualivemsg :imalivemsg :okmsg :failmsg :grmsg :gbrmsg :gmmsg :gcmsg :lsmsg :lsrmsg :manifest :remotenode :sessionuuid :socket :strm :usec)) @@ -30,6 +30,8 @@ (defconstant +gsinfo+ #x0305) ; Session Information (defconstant +gsgr+ #x0400) ; Geometry Request (defconstant +gsgbr+ #x0401) ; Geometry BoT Request +(defconstant +gsls+ #x0402) ; Geometry list request +(defconstant +gslsr+ #x0402) ; Geometry list response (defconstant +gsgm+ #x0405) ; Geometry Manifest (defconstant +gsgc+ #x0410) ; Geometry Chunk @@ -98,6 +100,8 @@ (let ((arr (make-array (+ (readuint32 (strm s)) 1) :element-type '(unsigned-byte 8)))) (read-sequence arr (strm s)) arr))) + ((= type +gsls+) (make-instance 'grmsg :uri (readgsstring (strm s)))) + ((= type +gslsr+) (make-instance 'gmmsg :manifest (loop for i from 1 to (readuint32 (strm s)) collect (readgsstring (strm s))))) ((= type +gsnsr+) (make-instance 'nsrmsg :username (readgsstring (strm s)) :password (readgsstring (strm s)))) (t (format t "Unknown type! ~a ~x~%" (type-of type) type)))) '())) @@ -141,3 +145,5 @@ (msg gbr ((uri :accessor uri :initarg :uri :initform "")) (+ (length (uri m)) 4) (writegsstring (strm s) (uri m))) (msg gm ((manifest :accessor manifest :initarg :manifest)) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))) (progn (writeuint32 (strm s) (length (manifest m))) (loop for i in (manifest m) do (writegsstring (strm s) i)))) (msg gc ((chunk :accessor chunk :initarg :chunk)) (+ (length (chunk m)) 4) (progn (writeuint32 (strm s) (- (length (chunk m)) 1)) (write-sequence (chunk m) (strm s)))) +(msg ls ((uri :accessor uri :initarg :uri :initform "")) (+ (length (uri m)) 4) (writegsstring (strm s) (uri m))) +(msg lsr ((manifest :accessor manifest :initarg :manifest)) (apply #'+ 4 (mapcar (lambda (x) (+ (length x) 4)) (manifest m))) (progn (writeuint32 (strm s) (length (manifest m))) (loop for i in (manifest m) do (writegsstring (strm s) i)))) Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-26 15:44:32 UTC (rev 44509) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-26 16:17:37 UTC (rev 44510) @@ -30,10 +30,15 @@ (defun send-bot-geom (s reuuid filename) (gsnet:writemsg s (make-instance 'gsnet:failmsg))) +(defun send-ls (s uri) + ;;; need some more stuff from gvm + (gsnet:writemsg s (make-instance 'gsnet:lsrmsg :manifest '("Some stuff" "some other stuff")))) + (defun handle-packet (s m) (cond ((equalp (type-of m) 'gsnet:grmsg) (send-geom s (gsnet::uuid m) (gsnet::uri m))) ((equalp (type-of m) 'gsnet:gbrmsg) (send-bot-geom s (gsnet::uuid m) (gsnet::uri m))) + ((equalp (type-of m) 'gsnet:lsmsg) (send-ls s (gsnet::uri m))) ((equalp m t) m) ((equalp m '()) m) (t (format t "Unhandled thing ~a~%" (type-of m))))) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <eri...@us...> - 2011-04-26 17:15:32
|
Revision: 44512 http://brlcad.svn.sourceforge.net/brlcad/?rev=44512&view=rev Author: erikgreenwald Date: 2011-04-26 17:15:26 +0000 (Tue, 26 Apr 2011) Log Message: ----------- throw an exception when gvm-open doesn't work Modified Paths: -------------- geomcore/trunk/src/interfaces/cl/gsserver.lisp geomcore/trunk/src/interfaces/cl/gvm.lisp Modified: geomcore/trunk/src/interfaces/cl/gsserver.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-26 17:13:56 UTC (rev 44511) +++ geomcore/trunk/src/interfaces/cl/gsserver.lisp 2011-04-26 17:15:26 UTC (rev 44512) @@ -9,6 +9,7 @@ (defvar *dbdir* "GS_repository") (defvar *nodename* "Spokelse") +(defvar *verbose* t) (defun authenticate (s user pass) (setf (gsnet::username s) user) @@ -16,16 +17,18 @@ (and (string= user "Guest") (string= pass "Guest"))) (defun send-geom (s reuuid filename) - (let ((repo (gvm:gvm-open *dbdir*)) - (tmpnam (sb-posix:mktemp "cltmp.XXXXX"))) - (gvm:gvm-export-g-file repo filename tmpnam gvm:+latest-version+) - (with-open-file (f tmpnam :element-type '(unsigned-byte 8) :if-does-not-exist :error) - (let ((arr (make-array (+ (file-length f) 1) :element-type '(unsigned-byte 8)))) - (gsnet:writemsg s (make-instance 'gsnet:gmmsg :manifest (list filename))) - (read-sequence arr f) - (gsnet:writemsg s (make-instance 'gsnet:gcmsg :chunk arr :reuuid reuuid)))) - (sb-posix:unlink tmpnam) - (gvm:gvm-close-repo repo))) + (handler-case + (let ((repo (gvm:gvm-open *dbdir*)) + (tmpnam (sb-posix:mktemp "cltmp.XXXXX"))) + (gvm:gvm-export-g-file repo filename tmpnam gvm:+latest-version+) + (with-open-file (f tmpnam :element-type '(unsigned-byte 8) :if-does-not-exist :error) + (let ((arr (make-array (+ (file-length f) 1) :element-type '(unsigned-byte 8)))) + (gsnet:writemsg s (make-instance 'gsnet:gmmsg :manifest (list filename))) + (read-sequence arr f) + (gsnet:writemsg s (make-instance 'gsnet:gcmsg :chunk arr :reuuid reuuid)))) + (sb-posix:unlink tmpnam) + (gvm:gvm-close-repo repo)) + (gvm::no-such-repo (p) (gsnet:writemsg s (make-instance 'gsnet:failmsg))))) (defun send-bot-geom (s reuuid filename) (gsnet:writemsg s (make-instance 'gsnet:failmsg))) @@ -35,6 +38,7 @@ (gsnet:writemsg s (make-instance 'gsnet:lsrmsg :manifest '("Some stuff" "some other stuff")))) (defun handle-packet (s m) + (when *verbose* (format t "Handling ~a~%" (type-of m))) (cond ((equalp (type-of m) 'gsnet:grmsg) (send-geom s (gsnet::uuid m) (gsnet::uri m))) ((equalp (type-of m) 'gsnet:gbrmsg) (send-bot-geom s (gsnet::uuid m) (gsnet::uri m))) @@ -65,7 +69,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun run (&key (listenhost #(127 0 0 1)) (port 5309) (multi-threading t) (in-new-thread t)) - (usocket:socket-server listenhost port #'handle-connection '() :element-type 'unsigned-byte :multi-threading multi-threading :in-new-thread in-new-thread)) + (usocket:socket-server listenhost port #'handle-connection '() :element-type 'unsigned-byte :multi-threading multi-threading :in-new-thread in-new-thread :reuse-address t)) (defun stop () (map 'nil (lambda (th) Modified: geomcore/trunk/src/interfaces/cl/gvm.lisp =================================================================== --- geomcore/trunk/src/interfaces/cl/gvm.lisp 2011-04-26 17:13:56 UTC (rev 44511) +++ geomcore/trunk/src/interfaces/cl/gvm.lisp 2011-04-26 17:15:26 UTC (rev 44512) @@ -70,13 +70,14 @@ (defcfun "gvm_export_object" :int (repo_info :pointer) (model_name :string) (obj_name :string) (g_file :string) (ver_num size_t) (recursive :int)) ; attempt to open a repo, creating if necessary +(define-condition no-such-repo (error) ((path :initarg :path :reader path))) (defun gvm-open (path) (let ((info (foreign-alloc :pointer :count 3))) (if (= (gvm-open-repo info path) 0) info (if (= (gvm-init-repo info path) 0) info - nil)))) + (error 'no-such-repo :path path))))) (defparameter +repo-file+ "./GS_repository") (defun test (file &key (something '())) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |