[usocket-cvs] r426 - in usocket/branches/experimental-udp: . backend
ctian at common-lisp.net
ctian at common-lisp.net
Fri Oct 3 12:49:41 UTC 2008
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))
More information about the usocket-cvs
mailing list