October 2008 - usocket-cvs@common-lisp.net

[usocket-cvs] r432 - in usocket/branches/experimental-udp: . backend
by Chun Tian 20 Oct '08

20 Oct '08

Author: ctian Date: Mon Oct 20 07:33:49 2008 New Revision: 432 Log: [udp] add SCL support, untested. Modified: usocket/branches/experimental-udp/backend/cmucl.lisp usocket/branches/experimental-udp/backend/scl.lisp usocket/branches/experimental-udp/rtt-client.lisp usocket/branches/experimental-udp/usocket.lisp Modified: usocket/branches/experimental-udp/backend/cmucl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/cmucl.lisp (original) +++ usocket/branches/experimental-udp/backend/cmucl.lisp Mon Oct 20 07:33:49 2008 @@ -80,21 +80,24 @@ (let ((err (unix:unix-errno))) (when err (cmucl-map-socket-error err))))) (:datagram - (if (and host port) - (setf socket (with-mapped-conditions (socket) - (ext:connect-to-inet-socket (host-to-hbo host) port :datagram - :local-host (host-to-hbo local-host) - :local-port local-port))) - (progn - (setf socket (with-mapped-conditions (socket) - (ext:create-inet-socket :datagram))) - (when (and local-host local-port) - (with-mapped-conditions (socket) - (ext:bind-inet-socket socket local-host local-port))))) - (let ((usocket (make-datagram-socket socket))) - (ext:finalize usocket #'(lambda () (when (%open-p usocket) - (ext:close-socket socket)))) - usocket))))) + (setf socket + (if (and host port) + (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port :datagram + :local-host (host-to-hbo local-host) + :local-port local-port)) + (if (or local-host local-port) + (with-mapped-conditions (socket) + (ext:create-inet-listener (or local-port 0) :datagram :host local-host)) + (with-mapped-conditoins (socket) + (ext:create-inet-socket :datagram))))) + (if socket + (let ((usocket (make-datagram-socket socket))) + (ext:finalize usocket #'(lambda () (when (%open-p usocket) + (ext:close-socket socket)))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))))) (defun socket-listen (host port &key reuseaddress Modified: usocket/branches/experimental-udp/backend/scl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/scl.lisp (original) +++ usocket/branches/experimental-udp/backend/scl.lisp Mon Oct 20 07:33:49 2008 @@ -28,7 +28,7 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) @@ -39,13 +39,41 @@ (unsupported 'local-host 'socket-connect) (unsupported 'local-port 'socket-connect)) - (let* ((socket (with-mapped-conditions () - (ext:connect-to-inet-socket (host-to-hbo host) port - :kind :stream))) - (stream (sys:make-fd-stream socket :input t :output t - :element-type element-type - :buffering :full))) - (make-stream-socket :socket socket :stream stream))) + (let ((socket)) + (ecase protocol + (:stream + (setf socket (with-mapped-conditions () + (ext:connect-to-inet-socket (host-to-hbo host) port + :kind :stream + #+ignore #+ignore + #+ignore #+ignore + :local-host (if local-host + (host-to-hbo local-host)) + :local-port local-port))) + (let ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + (:datagram + (setf socket + (if (and host port) + (with-mapped-conditions () + (ext:connect-to-inet-socket (host-to-hbo host) port + :kind :datagram + :local-host (host-to-hbo local-host) + :local-port local-port)) + (if (or local-port local-port) + (with-mapped-conditions () + (ext:create-inet-listener (or local-port 0) + :datagram + :host local-host)) + (with-mapped-conditions () + (ext:create-inet-socket :datagram))))) + (let ((usocket (make-datagram-socket socket))) + (ext:finalize usocket #'(lambda () + (when (%open-p usocket) + (ext:close-socket socket)))) + usocket))))) (defun socket-listen (host port &key reuseaddress @@ -91,6 +119,33 @@ (with-mapped-conditions (usocket) (close (socket-stream usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%open-p socket) nil)) + +(defmethod socket-send ((socket datagram-usocket) buffer length &key address port) + (let ((s (socket socket)) + (address (if address (host-to-hbo address)))) + (multiple-value-bind (result errno) + (ext:inet-socket-send-to s buffer length + :remote-host address :remote-port port) + (unless result + (error "~@<Error sending on socket ~D: ~A~@:>" s + (unix:get-unix-error-msg errno))) + result))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length) + (let ((s (socket socket))) + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (result errno remote-host remote-port) + (ext:inet-socket-receive-from s real-buffer real-length) + (unless result + (error "~@<Error receiving on socket ~D: ~A~@:>" s + (unix:get-unix-error-msg errno))) + (values real-buffer result remote-host remote-port))))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) (with-mapped-conditions (usocket) Modified: usocket/branches/experimental-udp/rtt-client.lisp ============================================================================== --- usocket/branches/experimental-udp/rtt-client.lisp (original) +++ usocket/branches/experimental-udp/rtt-client.lisp Mon Oct 20 07:33:49 2008 @@ -44,7 +44,7 @@ :old-rto old-rto :new-rto (slot-value socket 'rto)) (unless continue-p - (error 'rtt-timeout-error) - (rtt-init socket)))))) + (rtt-init socket) + (error 'rtt-timeout-error)))))) until (or recv-message (not continue-p)) finally (return recv-message))))) Modified: usocket/branches/experimental-udp/usocket.lisp ============================================================================== --- usocket/branches/experimental-udp/usocket.lisp (original) +++ usocket/branches/experimental-udp/usocket.lisp Mon Oct 20 07:33:49 2008 @@ -88,12 +88,12 @@ ((connected-p :type boolean :accessor connected-p :initarg :connected-p) - #+(or cmu lispworks) + #+(or cmu scl lispworks) (%open-p :type boolean :accessor %open-p :initform t :documentation "Flag to indicate if usocket is open, -for GC on LispWorks/CMUCL")) +for GC on implementions operate on raw socket fd.")) (:documentation "UDP (inet-datagram) socket")) (defun usocket-p (socket)

1 0

[usocket-cvs] r431 - in usocket/branches/experimental-udp: . backend
by Chun Tian 13 Oct '08

13 Oct '08

Author: ctian Date: Mon Oct 13 02:05:28 2008 New Revision: 431 Log: [udp] use :datagram instead of :udp, extend HOST-TO-HBO to support NIL Modified: usocket/branches/experimental-udp/backend/allegro.lisp usocket/branches/experimental-udp/backend/cmucl.lisp usocket/branches/experimental-udp/backend/openmcl.lisp usocket/branches/experimental-udp/backend/sbcl.lisp usocket/branches/experimental-udp/package.lisp usocket/branches/experimental-udp/server.lisp usocket/branches/experimental-udp/usocket.lisp Modified: usocket/branches/experimental-udp/backend/allegro.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/allegro.lisp (original) +++ usocket/branches/experimental-udp/backend/allegro.lisp Mon Oct 13 02:05:28 2008 @@ -64,7 +64,7 @@ (labels ((make-socket () (socket:make-socket :remote-host (host-to-hostname host) :remote-port port - :local-host (when local-host (host-to-hostname local-host)) + :local-host (host-to-hostname local-host) :local-port local-port :format (to-format element-type) :nodelay nodelay))) @@ -79,13 +79,13 @@ :connect :active :remote-host (host-to-hostname host) :remote-port port - :local-host (when local-host (host-to-hostname local-host)) + :local-host (host-to-hostname local-host) :local-port local-port :format (to-format element-type)) (socket:make-socket :type :datagram :address-family :internet :local-host local-host - :local-port (when local-host (host-to-hostname local-host)) + :local-port (host-to-hostname local-host) :format (to-format element-type))))))) (ecase protocol (:stream Modified: usocket/branches/experimental-udp/backend/cmucl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/cmucl.lisp (original) +++ usocket/branches/experimental-udp/backend/cmucl.lisp Mon Oct 13 02:05:28 2008 @@ -67,8 +67,7 @@ (setf socket (with-mapped-conditions (socket) (ext:connect-to-inet-socket (host-to-hbo host) port :stream - :local-host (if local-host - (host-to-hbo local-host)) + :local-host (host-to-hbo local-host) :local-port local-port))) (if socket (let* ((stream (sys:make-fd-stream socket :input t :output t @@ -84,8 +83,7 @@ (if (and host port) (setf socket (with-mapped-conditions (socket) (ext:connect-to-inet-socket (host-to-hbo host) port :datagram - :local-host (if local-host - (host-to-hbo local-host)) + :local-host (host-to-hbo local-host) :local-port local-port))) (progn (setf socket (with-mapped-conditions (socket) Modified: usocket/branches/experimental-udp/backend/openmcl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/openmcl.lisp (original) +++ usocket/branches/experimental-udp/backend/openmcl.lisp Mon Oct 13 02:05:28 2008 @@ -81,9 +81,9 @@ (ecase protocol (:stream (let ((mcl-sock - (openmcl-socket:make-socket :remote-host (host-to-hostname host) + (openmcl-socket:make-socket :remote-host (host-to-hbo host) :remote-port port - :local-host (when local-host (host-to-hostname local-host)) + :local-host (host-to-hbo local-host) :local-port local-port :format (to-format element-type) :deadline deadline @@ -96,8 +96,7 @@ (let ((mcl-sock (openmcl-socket:make-socket :address-family :internet :type :datagram - :local-host (if local-host - (host-to-hbo local-host)) + :local-host (host-to-hbo local-host) :local-port local-port))) (when (and host port) (ccl::inet-connect (ccl::socket-device mcl-sock) @@ -140,7 +139,7 @@ (defmethod socket-send ((usocket datagram-usocket) buffer length &key address port) (with-mapped-conditions (usocket) (openmcl-socket:send-to (socket usocket) buffer length - :remote-host (if address (host-to-hbo address)) + :remote-host (host-to-hbo address) :remote-port port))) (defmethod socket-receive ((usocket datagram-usocket) buffer length) Modified: usocket/branches/experimental-udp/backend/sbcl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/sbcl.lisp (original) +++ usocket/branches/experimental-udp/backend/sbcl.lisp Mon Oct 13 02:05:28 2008 @@ -240,10 +240,11 @@ (sb-bsd-sockets:socket-connect socket ip port)) usocket)) (:datagram - (when (and local-host local-port) + (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket - (host-to-vector-quad local-host) - local-port)) + (host-to-vector-quad + (or local-host *wildcard-host*)) + (or local-port *auto-port*))) (when (and host port) (sb-bsd-sockets:socket-connect socket (host-to-hbo host) port)) (make-datagram-socket socket))) Modified: usocket/branches/experimental-udp/package.lisp ============================================================================== --- usocket/branches/experimental-udp/package.lisp (original) +++ usocket/branches/experimental-udp/package.lisp Mon Oct 13 02:05:28 2008 @@ -80,25 +80,4 @@ #:insufficient-implementation ; conditions regarding usocket support level #:unsupported - #:unimplemented) - - #+lispworks - (:import-from :comm - #:*socket_af_inet* - #:*socket_pf_unspec* - #:*sockopt_sol_socket* - #:%send - #:bind - #:close-socket - #:connect - #:getsockopt - #:in_addr - #:initialize-sockaddr_in - #:ntohl - #:ntohs - #:s_addr - #:setsockopt - #:sin_addr - #:sin_port - #:sockaddr - #:sockaddr_in)) + #:unimplemented)) Modified: usocket/branches/experimental-udp/server.lisp ============================================================================== --- usocket/branches/experimental-udp/server.lisp (original) +++ usocket/branches/experimental-udp/server.lisp Mon Oct 13 02:05:28 2008 @@ -10,7 +10,7 @@ &key (element-type '(unsigned-byte 8)) (timeout 1) (max-buffer-size +max-datagram-packet-size+)) (let ((socket (socket-connect nil nil - :protocol :udp + :protocol :datagram :local-host host :local-port port :element-type element-type)) Modified: usocket/branches/experimental-udp/usocket.lisp ============================================================================== --- usocket/branches/experimental-udp/usocket.lisp (original) +++ usocket/branches/experimental-udp/usocket.lisp Mon Oct 13 02:05:28 2008 @@ -407,6 +407,7 @@ (defun host-to-hostname (host) "Translate a string or vector quad to a stringified hostname." (etypecase host + (null nil) (string host) ((or (vector t 4) (array (unsigned-byte 8) (4))) @@ -460,6 +461,7 @@ (defun host-to-hbo (host) (etypecase host + (null nil) (string (let ((ip (ignore-errors (dotted-quad-to-vector-quad host)))) (if (and ip (= 4 (length ip)))

1 0

[usocket-cvs] r426 - in usocket/branches/experimental-udp: . backend
by ctian＠common-lisp.net 03 Oct '08

03 Oct '08

Author: ctian Date: Fri Oct 3 08:49:40 2008 New Revision: 426 Added: usocket/branches/experimental-udp/rtt-client.lisp (contents, props changed) usocket/branches/experimental-udp/rtt.lisp (contents, props changed) usocket/branches/experimental-udp/server.lisp (contents, props changed) Modified: usocket/branches/experimental-udp/backend/allegro.lisp usocket/branches/experimental-udp/backend/cmucl.lisp usocket/branches/experimental-udp/backend/lispworks.lisp usocket/branches/experimental-udp/backend/openmcl.lisp usocket/branches/experimental-udp/backend/sbcl.lisp usocket/branches/experimental-udp/condition.lisp usocket/branches/experimental-udp/package.lisp usocket/branches/experimental-udp/usocket.asd usocket/branches/experimental-udp/usocket.lisp Log: [experimental-udp] initial commit, no support on scl/clisp/armedbear, buggy on others. Modified: usocket/branches/experimental-udp/backend/allegro.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/allegro.lisp (original) +++ usocket/branches/experimental-udp/backend/allegro.lisp Fri Oct 3 08:49:40 2008 @@ -49,7 +49,7 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :tcp) (element-type 'character) timeout deadline (nodelay t) ;; nodelay == t is the ACL default local-host local-port) @@ -59,22 +59,38 @@ (let ((socket)) (setf socket (with-mapped-conditions (socket) - (if timeout - (mp:with-timeout (timeout nil) - (socket:make-socket :remote-host (host-to-hostname host) - :remote-port port - :local-host (when local-host (host-to-hostname local-host)) - :local-port local-port - :format (to-format element-type) - :nodelay nodelay)) - (socket:make-socket :remote-host (host-to-hostname host) - :remote-port port - :local-host local-host - :local-port local-port - :format (to-format element-type) - :nodelay nodelay)))) - (make-stream-socket :socket socket :stream socket))) - + (ecase protocol + (:tcp (if timeout + (mp:with-timeout (timeout nil) + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :nodelay nodelay)) + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :nodelay nodelay))) + (:udp (if (and host port) + (socket:make-socket :type :datagram + :address-family :internet + :connect :active + :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type)) + (socket:make-socket :type :datagram + :address-family :internet + :local-host local-host + :local-port (when local-host (host-to-hostname local-host)) + :format (to-format element-type))))))) + (ecase protocol + (:tcp (make-stream-socket :socket socket :stream socket)) + (:udp (make-datagram-socket socket))))) ;; One socket close method is sufficient, ;; because socket-streams are also sockets. @@ -113,6 +129,16 @@ (socket:accept-connection (socket socket))))) (make-stream-socket :socket stream-sock :stream stream-sock))) +(defmethod socket-send ((socket datagram-usocket) buffer length &key address port) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (socket:send-to s buffer length :remote-host address :remote-port port)))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (socket:receive-from s length :buffer buffer :extract t)))) + (defmethod get-local-address ((usocket usocket)) (hbo-to-vector-quad (socket:local-host (socket usocket)))) Modified: usocket/branches/experimental-udp/backend/cmucl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/cmucl.lisp (original) +++ usocket/branches/experimental-udp/backend/cmucl.lisp Fri Oct 3 08:49:40 2008 @@ -50,7 +50,7 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :tcp) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) @@ -61,20 +61,43 @@ (unsupported 'local-host 'socket-connect) (unsupported 'local-port 'socket-connect)) - (let* ((socket)) - (setf socket - (with-mapped-conditions (socket) - (ext:connect-to-inet-socket (host-to-hbo host) port :stream))) - (if socket - (let* ((stream (sys:make-fd-stream socket :input t :output t - :element-type element-type - :buffering :full)) - ;;###FIXME the above line probably needs an :external-format - (usocket (make-stream-socket :socket socket - :stream stream))) - usocket) - (let ((err (unix:unix-errno))) - (when err (cmucl-map-socket-error err)))))) + (let ((socket)) + (ecase protocol + (:tcp (progn + (setf socket + (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port + (cdr (assoc protocol +protocol-map+)) + :local-host (if local-host + (host-to-hbo local-host)) + :local-port local-port))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))) + (:udp (progn + (if (and host port) + (setf socket (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port :datagram + :local-host (if local-host + (host-to-hbo local-host)) + :local-port local-port))) + (progn + (setf socket (with-mapped-conditions (socket) + (ext:create-inet-socket :datagram))) + (when (and local-host local-port) + (with-mapped-conditions (socket) + (ext:bind-inet-socket socket local-host local-port))))) + (let ((usocket (make-datagram-socket socket))) + (ext:finalize usocket #'(lambda () (unless (%closed-p usocket) + (ext:close-socket socket)))) + usocket)))))) (defun socket-listen (host port &key reuseaddress @@ -119,6 +142,24 @@ (with-mapped-conditions (usocket) (ext:close-socket (socket usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%closed-p socket) t)) + +(defmethod socket-send ((usocket datagram-usocket) buffer length &key address port) + (with-mapped-conditions (usocket) + (ext:inet-sendto (socket usocket) buffer length (if address (host-to-hbo address)) port))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length) + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (nbytes remote-host remote-port) + (with-mapped-conditions (usocket) + (ext:inet-recvfrom (socket usocket) real-buffer real-length)) + (when (plusp nbytes) + (values real-buffer nbytes remote-host remote-port))))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) Modified: usocket/branches/experimental-udp/backend/lispworks.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/lispworks.lisp (original) +++ usocket/branches/experimental-udp/backend/lispworks.lisp Fri Oct 3 08:49:40 2008 @@ -73,7 +73,7 @@ (declare (ignore host port err-msg)) (raise-usock-err errno socket condition))))) -(defun socket-connect (host port &key (element-type 'base-char) +(defun socket-connect (host port &key (protocol :tcp) (element-type 'base-char) timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignorable nodelay)) @@ -87,23 +87,36 @@ (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0+ (verified)") (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0+ (verified)")) - (let ((hostname (host-to-hostname host)) - (stream)) - (setf stream - (with-mapped-conditions () - (comm:open-tcp-stream hostname port - :element-type element-type - #-lispworks4 #-lispworks4 - #-lispworks4 #-lispworks4 - :local-address (when local-host (host-to-hostname local-host)) - :local-port local-port - #+(and (not lispworks4) (not lispworks5.0)) - #+(and (not lispworks4) (not lispworks5.0)) - :nodelay nodelay))) - (if stream - (make-stream-socket :socket (comm:socket-stream-socket stream) - :stream stream) - (error 'unknown-error)))) + (ecase protocol + (:tcp (let ((hostname (host-to-hostname host)) + (stream)) + (setf stream + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type + #-lispworks4 #-lispworks4 + #-lispworks4 #-lispworks4 + :local-address (when local-host (host-to-hostname local-host)) + :local-port local-port + #+(and (not lispworks4) (not lispworks5.0)) + #+(and (not lispworks4) (not lispworks5.0)) + :nodelay nodelay))) + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + (error 'unknown-error)))) + (:udp (let ((usocket (make-datagram-socket + (if (and host port) + (comm:connect-to-udp-server host port + :errorp t + :local-address local-host + :local-port local-port) + (comm:open-udp-socket :errorp t + :local-address local-host + :local-port local-port)) + :connected-p t))) + (hcl:flag-special-free-action usocket) + usocket)))) (defun socket-listen (host port &key reuseaddress @@ -152,6 +165,27 @@ (with-mapped-conditions (usocket) (comm::close-socket (socket usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + "Additional socket-close method for datagram-usocket" + (setf (%closed-p socket) t)) + +;; Register a special free action for closing datagram usocket when being GCed +(defun usocket-special-free-action (object) + (when (and (typep object 'datagram-usocket) + (not (closed-p object))) + (socket-close object))) + +(eval-when (:load-toplevel :execute) + (hcl:add-special-free-action 'usocket-special-free-action)) + +(defmethod socket-send ((socket datagram-usocket) buffer length &key address port) + (let ((s (socket socket))) + (comm:send-message s buffer length address port))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length) + (let ((s (socket socket))) + (comm:receive-message s buffer length))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) Modified: usocket/branches/experimental-udp/backend/openmcl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/openmcl.lisp (original) +++ usocket/branches/experimental-udp/backend/openmcl.lisp Fri Oct 3 08:49:40 2008 @@ -74,21 +74,36 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay +(defun socket-connect (host port &key (protocol :tcp) (element-type 'character) + timeout deadline nodelay local-host local-port) (with-mapped-conditions () - (let ((mcl-sock - (openmcl-socket:make-socket :remote-host (host-to-hostname host) - :remote-port port - :local-host (when local-host (host-to-hostname local-host)) - :local-port local-port - :format (to-format element-type) - :deadline deadline - :nodelay nodelay - :connect-timeout (and timeout - (* timeout internal-time-units-per-second))))) - (openmcl-socket:socket-connect mcl-sock) - (make-stream-socket :stream mcl-sock :socket mcl-sock)))) + (ecase protocol + (:tcp + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :deadline deadline + :nodelay nodelay + :connect-timeout (and timeout + (* timeout internal-time-units-per-second))))) + (openmcl-socket:socket-connect mcl-sock) + (make-stream-socket :stream mcl-sock :socket mcl-sock))) + (:udp + (let ((mcl-sock + (openmcl-socket:make-socket :address-family :internet + :type :datagram + :local-host (if local-host + (host-to-hbo local-host)) + :local-port local-port))) + (when (and host port) + (ccl::inet-connect (ccl::socket-device mcl-sock) + (ccl::host-as-inet-host host) + (ccl::port-as-inet-port port "udp"))) + (make-datagram-socket mcl-sock)))))) (defun socket-listen (host port &key reuseaddress @@ -122,6 +137,16 @@ (with-mapped-conditions (usocket) (close (socket usocket)))) +(defmethod socket-send ((usocket datagram-usocket) buffer length &key address port) + (with-mapped-conditions (usocket) + (openmcl-socket:send-to (socket usocket) buffer length + :remote-host (if address (host-to-hbo address)) + :remote-port port))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length) + (with-mapped-conditions (usocket) + (openmcl-socket:receive-from (socket usocket) length :buffer buffer))) + (defmethod get-local-address ((usocket usocket)) (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket)))) Modified: usocket/branches/experimental-udp/backend/sbcl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/sbcl.lisp (original) +++ usocket/branches/experimental-udp/backend/sbcl.lisp Fri Oct 3 08:49:40 2008 @@ -199,8 +199,7 @@ (if usock-cond (signal usock-cond :socket socket)))))) - -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :tcp) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) (when deadline (unsupported 'deadline 'socket-connect)) @@ -214,28 +213,38 @@ (unsupported 'nodelay 'socket-connect)) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket - :type :stream :protocol :tcp))) + :type (cdr (assoc protocol +protocol-map+)) + :protocol protocol))) (handler-case - (let* ((stream - (sb-bsd-sockets:socket-make-stream socket - :input t - :output t - :buffering :full - :element-type element-type)) - ;;###FIXME: The above line probably needs an :external-format - (usocket (make-stream-socket :stream stream :socket socket)) - (ip (host-to-vector-quad host))) - (when (and nodelay-specified - (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)) - (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay)) - (when (or local-host local-port) - (sb-bsd-sockets:socket-bind socket - (host-to-vector-quad - (or local-host *wildcard-host*)) - (or local-port *auto-port*))) - (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port)) - usocket) + (ecase protocol + (:tcp (let* ((stream + (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + :element-type element-type)) + ;;###FIXME: The above line probably needs an :external-format + (usocket (make-stream-socket :stream stream :socket socket)) + (ip (host-to-vector-quad host))) + (when (and nodelay-specified + (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)) + (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay)) + (when (or local-host local-port) + (sb-bsd-sockets:socket-bind socket + (host-to-vector-quad + (or local-host *wildcard-host*)) + (or local-port *auto-port*))) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port)) + usocket)) + (:udp (progn + (when (and local-host local-port) + (sb-bsd-sockets:socket-bind socket + (host-to-vector-quad local-host) + local-port)) + (when (and host port) + (sb-bsd-sockets:socket-connect socket (host-to-hbo host) port)) + (make-datagram-socket socket)))) (t (c) ;; Make sure we don't leak filedescriptors (sb-bsd-sockets:socket-close socket) @@ -287,6 +296,18 @@ (with-mapped-conditions (usocket) (close (socket-stream usocket)))) +(defmethod socket-send ((socket datagram-usocket) buffer length &key address port) + (with-mapped-conditions (socket) + (let* ((s (socket socket)) + (dest (if (and address port) (list (host-to-vector-quad address) port) nil))) + (sb-bsd-sockets:socket-send s buffer length :address dest)))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length + &key (element-type '(unsigned-byte 8))) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) + (defmethod get-local-name ((usocket usocket)) (sb-bsd-sockets:socket-name (socket usocket))) Modified: usocket/branches/experimental-udp/condition.lisp ============================================================================== --- usocket/branches/experimental-udp/condition.lisp (original) +++ usocket/branches/experimental-udp/condition.lisp Fri Oct 3 08:49:40 2008 @@ -197,4 +197,44 @@ :context ,context :minimum ,minimum)) (defmacro unimplemented (feature context) - `(signal 'unimplemented :feature ,feature :context ,context)) \ No newline at end of file + `(signal 'unimplemented :feature ,feature :context ,context)) + +;;; binghe: socket-warning for UDP retransmit support + +(define-condition socket-warning (socket-condition warning) + () ;; no slots (yet) + (:documentation "Parent warning for all socket related warnings")) + +(define-condition rtt-timeout-warning (socket-warning) + ((old-rto :type short-float + :reader old-rto-of + :initarg :old-rto) + (new-rto :type short-float + :reader new-rto-of + :initarg :new-rto)) + (:report (lambda (condition stream) + (format stream "Receive timeout (~As), next: ~As.~%" + (old-rto-of condition) + (new-rto-of condition)))) + (:documentation "RTT timeout warning")) + +(define-condition rtt-seq-mismatch-warning (socket-warning) + ((send-seq :type integer + :reader send-seq-of + :initarg :send-seq) + (recv-seq :type integer + :reader recv-seq-of + :initarg :recv-seq)) + (:report (lambda (condition stream) + (format stream "Sequence number mismatch (~A -> ~A), try read again.~%" + (send-seq-of condition) + (recv-seq-of condition)))) + (:documentation "RTT sequence mismatch warning")) + +(define-condition rtt-timeout-error (socket-error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "Max retransmit times (~A) reached, give up.~%" + *rtt-maxnrexmt*))) + (:documentation "RTT timeout error")) Modified: usocket/branches/experimental-udp/package.lisp ============================================================================== --- usocket/branches/experimental-udp/package.lisp (original) +++ usocket/branches/experimental-udp/package.lisp Fri Oct 3 08:49:40 2008 @@ -11,6 +11,9 @@ (:export #:*wildcard-host* #:*auto-port* + #:*remote-host* ; special variables (udp) + #:*remote-port* + #:socket-connect ; socket constructors and methods #:socket-listen #:socket-accept @@ -22,6 +25,11 @@ #:get-local-name #:get-peer-name + #:socket-send ; udp function (send) + #:socket-receive ; udp function (receive) + #:socket-sync ; udp client (high-level) + #:socket-server ; udp server + #:wait-for-input ; waiting for input-ready state (select() like) #:make-wait-list #:add-waiter @@ -65,6 +73,7 @@ #:ns-unknown-condition #:unknown-error #:ns-unknown-error + #:socket-warning ; warnings (udp) #:insufficient-implementation ; conditions regarding usocket support level #:unsupported Added: usocket/branches/experimental-udp/rtt-client.lisp ============================================================================== --- (empty file) +++ usocket/branches/experimental-udp/rtt-client.lisp Fri Oct 3 08:49:40 2008 @@ -0,0 +1,50 @@ +;;;; $Id$ +;;;; $URL$ + +(in-package :usocket) + +(defun default-rtt-function (message) (values message 0)) + +(defmethod socket-sync ((socket datagram-usocket) message &key address port + (max-receive-length +max-datagram-packet-size+) + (encode-function #'default-rtt-function) + (decode-function #'default-rtt-function)) + (rtt-newpack socket) + (multiple-value-bind (data send-seq) (funcall encode-function message) + (let ((data-length (length data))) + (loop + with send-ts = (rtt-ts socket) + and recv-message = nil + and recv-seq = -1 + and continue-p = t + do (progn + (socket-send socket data data-length :address address :port port) + (multiple-value-bind (sockets real-time) + (wait-for-input socket :timeout (rtt-start socket)) + (declare (ignore sockets)) + (if real-time + ;; message received + (loop + do (multiple-value-setq (recv-message recv-seq) + (funcall decode-function + (socket-receive socket nil max-receive-length))) + until (or (= recv-seq send-seq) + (warn 'rtt-seq-mismatch-warning + :socket socket + :send-seq send-seq + :recv-seq recv-seq)) + finally (let ((recv-ts (rtt-ts socket))) + (rtt-stop socket (- recv-ts send-ts)) + (return nil))) + ;; message not received + (let ((old-rto (slot-value socket 'rto))) + (setf continue-p (rtt-timeout socket)) + (warn 'rtt-timeout-warning + :socket socket + :old-rto old-rto + :new-rto (slot-value socket 'rto)) + (unless continue-p + (error 'rtt-timeout-error) + (rtt-init socket)))))) + until (or recv-message (not continue-p)) + finally (return recv-message))))) Added: usocket/branches/experimental-udp/rtt.lisp ============================================================================== --- (empty file) +++ usocket/branches/experimental-udp/rtt.lisp Fri Oct 3 08:49:40 2008 @@ -0,0 +1,80 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; UDP retransmit support by Chun Tian (binghe) +;;;; See the LICENSE file for licensing information. + +(in-package :usocket) + +;;; UNIX Network Programming v1 - Networking APIs: Sockets and XTI +;;; Chapter 20: Advance UDP Sockets +;;; Adding Reliability to a UDP Application + +(defclass rtt-info-mixin () + ((rtt :type short-float + :documentation "most recent measured RTT, seconds") + (srtt :type short-float + :documentation "smoothed RTT estimator, seconds") + (rttvar :type short-float + :documentation "smoothed mean deviation, seconds") + (rto :type short-float + :documentation "current RTO to use, seconds") + (nrexmt :type fixnum + :documentation "#times retransmitted: 0, 1, 2, ...") + (base :type integer + :documentation "#sec since 1/1/1970 at start, but we use Lisp time here")) + (:documentation "RTT Info Class")) + +(defvar *rtt-rxtmin* 2.0 "min retransmit timeout value, seconds") +(defvar *rtt-rxtmax* 60.0 "max retransmit timeout value, seconds") +(defvar *rtt-maxnrexmt* 3 "max #times to retransmit") + +(defmethod rtt-rtocalc ((instance rtt-info-mixin)) + "Calculate the RTO value based on current estimators: + smoothed RTT plus four times the deviation." + (with-slots (srtt rttvar) instance + (+ srtt (* 4.0 rttvar)))) + +(defun rtt-minmax (rto) + "rtt-minmax makes certain that the RTO is between the upper and lower limits." + (declare (type short-float rto)) + (cond ((< rto *rtt-rxtmin*) *rtt-rxtmin*) + ((> rto *rtt-rxtmax*) *rtt-rxtmax*) + (t rto))) + +(defmethod initialize-instance :after ((instance rtt-info-mixin) &rest initargs + &key &allow-other-keys) + (declare (ignore initargs)) + (rtt-init instance)) + +(defmethod rtt-init ((instance rtt-info-mixin)) + (with-slots (base rtt srtt rttvar rto) instance + (setf base (get-internal-real-time) + rtt 0.0 + srtt 0.0 + rttvar 0.75 + rto (rtt-minmax (rtt-rtocalc instance))))) + +(defmethod rtt-ts ((instance rtt-info-mixin)) + (* (- (get-internal-real-time) (slot-value instance 'base)) + #.(/ 1000 internal-time-units-per-second))) + +(defmethod rtt-start ((instance rtt-info-mixin)) + "return value can be used as: alarm(rtt_start(&foo))" + (round (slot-value instance 'rto))) + +(defmethod rtt-stop ((instance rtt-info-mixin) (ms number)) + (with-slots (rtt srtt rttvar rto) instance + (setf rtt (/ ms 1000.0)) + (let ((delta (- rtt srtt))) + (incf srtt (/ delta 8.0)) + (incf rttvar (/ (- (abs delta) rttvar) 4.0))) + (setf rto (rtt-minmax (rtt-rtocalc instance))))) + +(defmethod rtt-timeout ((instance rtt-info-mixin)) + (with-slots (rto nrexmt) instance + (setf rto (* rto 2.0)) + (< (incf nrexmt) *rtt-maxnrexmt*))) + +(defmethod rtt-newpack ((instance rtt-info-mixin)) + (setf (slot-value instance 'nrexmt) 0)) Added: usocket/branches/experimental-udp/server.lisp ============================================================================== --- (empty file) +++ usocket/branches/experimental-udp/server.lisp Fri Oct 3 08:49:40 2008 @@ -0,0 +1,43 @@ +;;;; $Id$ +;;;; $URL$ + +(in-package :usocket) + +(defvar *remote-host*) +(defvar *remote-port*) + +(defun socket-server (host port function &optional arguments + &key (element-type '(unsigned-byte 8)) (timeout 1) + (max-buffer-size +max-datagram-packet-size+)) + (let ((socket (socket-connect nil nil + :protocol :udp + :local-host host + :local-port port + :element-type element-type)) + (buffer (make-array max-buffer-size + :element-type '(unsigned-byte 8) + :initial-element 0))) + (unwind-protect + (loop (progn + (multiple-value-bind (sockets real-time) + (wait-for-input socket :timeout timeout) + (declare (ignore sockets)) + (when real-time + (multiple-value-bind (recv n *remote-host* *remote-port*) + (socket-receive socket buffer max-buffer-size) + (declare (ignore recv)) + (if (plusp n) + (progn + (let ((reply + (apply function + (cons (subseq buffer 0 n) arguments)))) + (when reply + (replace buffer reply) + (let ((n (socket-send socket buffer (length reply) + :address *remote-host* + :port *remote-port*))) + (when (minusp n) + (error "send error: ~A~%" n)))))) + (error "receive error: ~A" n)))) + #+(and cmu mp) (mp:process-yield)))) + (socket-close socket)))) Modified: usocket/branches/experimental-udp/usocket.asd ============================================================================== --- usocket/branches/experimental-udp/usocket.asd (original) +++ usocket/branches/experimental-udp/usocket.asd Fri Oct 3 08:49:40 2008 @@ -1,4 +1,4 @@ - +;;;; -*- Mode: Lisp -*- ;;;; $Id$ ;;;; $URL$ @@ -18,26 +18,26 @@ :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (:split-sequence - #+sbcl :sb-bsd-sockets) + #+sbcl :sb-bsd-sockets + #+lispworks :lispworks-udp) :components ((:file "package") + (:file "rtt" + :depends-on ("package")) (:file "usocket" - :depends-on ("package")) + :depends-on ("package" "rtt")) (:file "condition" - :depends-on ("usocket")) - #+clisp (:file "clisp" :pathname "backend/clisp" - :depends-on ("condition")) - #+cmu (:file "cmucl" :pathname "backend/cmucl" - :depends-on ("condition")) - #+scl (:file "scl" :pathname "backend/scl" - :depends-on ("condition")) - #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl" - :depends-on ("condition")) - #+lispworks (:file "lispworks" :pathname "backend/lispworks" - :depends-on ("condition")) - #+openmcl (:file "openmcl" :pathname "backend/openmcl" - :depends-on ("condition")) - #+allegro (:file "allegro" :pathname "backend/allegro" - :depends-on ("condition")) - #+armedbear (:file "armedbear" :pathname "backend/armedbear" - :depends-on ("condition")) - )) + :depends-on ("usocket" "rtt")) + (:module "backend" + :components (#+clisp (:file "clisp") + #+cmu (:file "cmucl") + #+scl (:file "scl") + #+(or sbcl ecl) (:file "sbcl") + #+lispworks (:file "lispworks") + #+openmcl (:file "openmcl") + #+allegro (:file "allegro") + #+armedbear (:file "armedbear")) + :depends-on ("condition")) + (:file "rtt-client" + :depends-on ("rtt" "backend" "condition")) + (:file "server" + :depends-on ("backend")))) Modified: usocket/branches/experimental-udp/usocket.lisp ============================================================================== --- usocket/branches/experimental-udp/usocket.lisp (original) +++ usocket/branches/experimental-udp/usocket.lisp Fri Oct 3 08:49:40 2008 @@ -11,6 +11,9 @@ (defparameter *auto-port* 0 "Port number to pass when an auto-assigned port number is wanted.") +(defconstant +max-datagram-packet-size+ 65536) +(defconstant +protocol-map+ '((:tcp . :stream) (:udp . :datagram))) + (defclass usocket () ((socket :initarg :socket @@ -82,10 +85,17 @@ (:documentation "Socket which listens for stream connections to be initiated from remote sockets.")) -(defclass datagram-usocket (usocket) - ((connected-p :initarg :connected-p :accessor connected-p)) -;; ###FIXME: documentation to be added. - (:documentation "")) +(defclass datagram-usocket (usocket rtt-info-mixin) + ((connected-p :type boolean + :accessor connected-p + :initarg :connected-p) + #+(or cmu lispworks) + (%closed-p :type boolean + :accessor %closed-p + :initform nil + :documentation "Flag to indicate if this usocket is closed, +for GC on LispWorks/CMUCL")) + (:documentation "UDP (inet-datagram) socket")) (defun usocket-p (socket) (typep socket 'usocket))

1 0

[usocket-cvs] r425 - in usocket/branches/experimental-udp: . backend
by ctian＠common-lisp.net 02 Oct '08

02 Oct '08

Author: ctian Date: Thu Oct 2 18:48:46 2008 New Revision: 425 Added: usocket/branches/experimental-udp/ - copied from r424, usocket/trunk/ Modified: usocket/branches/experimental-udp/backend/lispworks.lisp Log: New branch: experimental UDP support Modified: usocket/branches/experimental-udp/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/branches/experimental-udp/backend/lispworks.lisp Thu Oct 2 18:48:46 2008 @@ -216,15 +216,20 @@ ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? (dolist (x (wait-list-waiters wait-list)) (mp:notice-fd (os-socket-handle x))) - (mp:process-wait-with-timeout "Waiting for a socket to become active" - (truncate timeout) - #'(lambda (socks) - (let (rv) - (dolist (x socks rv) - (when (usocket-listen x) - (setf (state x) :READ - rv t))))) - (wait-list-waiters wait-list)) + (labels ((wait-function (socks) + (let (rv) + (dolist (x socks rv) + (when (usocket-listen x) + (setf (state x) :READ + rv t)))))) + (if timeout + (mp:process-wait-with-timeout "Waiting for a socket to become active" + (truncate timeout) + #'wait-function + (wait-list-waiters wait-list)) + (mp:process-wait "Waiting for a socket to become active" + #'wait-function + (wait-list-waiters wait-list)))) (dolist (x (wait-list-waiters wait-list)) (mp:unnotice-fd (os-socket-handle x))) wait-list)))

1 0