[usocket-cvs] r505 - usocket/trunk/backend
Chun Tian (binghe)
ctian at common-lisp.net
Sun Jan 3 07:29:08 UTC 2010
Author: ctian
Date: Sun Jan 3 02:29:07 2010
New Revision: 505
Log:
Initial MCL backend support from Terje Norderhaug
Added:
usocket/trunk/backend/mcl.lisp (contents, props changed)
Added: usocket/trunk/backend/mcl.lisp
==============================================================================
--- (empty file)
+++ usocket/trunk/backend/mcl.lisp Sun Jan 3 02:29:07 2010
@@ -0,0 +1,258 @@
+;; MCL backend for USOCKET 0.4.1
+;; Terje Norderhaug <terje at in-progress.com>, January 1, 2009
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional socket)
+ ; incomplete, needs to handle additional conditions
+ (flet ((raise-error (&optional socket-condition)
+ (error (or socket-condition 'unknown-error) :socket socket :real-error condition)))
+ (typecase condition
+ (ccl:host-stopped-responding
+ (raise-error 'host-down-error))
+ (ccl:host-not-responding
+ (raise-error 'host-unreachable-error))
+ (ccl:connection-reset
+ (raise-error 'connection-reset-error))
+ (ccl:connection-timed-out
+ (raise-error 'timeout-error))
+ (ccl:opentransport-protocol-error
+ (raise-error ''protocol-not-supported-error))
+ (otherwise
+ (raise-error)))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
+ local-host local-port)
+ (let* ((socket
+ (make-instance 'active-socket
+ :remote-host (when host (host-to-hostname host))
+ :remote-port port
+ :local-host (when local-host (host-to-hostname local-host))
+ :local-port local-port
+ :deadline deadline
+ :nodelay nodelay
+ :connect-timeout (and timeout (round (* timeout 60)))
+ :element-type element-type))
+ (stream (socket-open-stream socket)))
+ (make-stream-socket :socket socket :stream stream)))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (declare (ignore reuseaddress reuse-address-supplied-p))
+ (let ((socket (make-instance 'passive-socket
+ :local-port port
+ :local-host host
+ :reuse-address reuse-address
+ :backlog backlog)))
+ (make-stream-server-socket socket :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (let* ((socket (socket usocket))
+ (stream (socket-accept socket :element-type element-type)))
+ (make-stream-socket :socket socket :stream stream)))
+
+(defmethod socket-close ((usocket usocket))
+ (with-mapped-conditions (usocket)
+ (socket-close (socket usocket))))
+
+(defmethod ccl::stream-close ((usocket usocket))
+ (socket-close usocket))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (list (hbo-to-vector-quad (ccl::get-host-address
+ (host-to-hostname name))))))
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (ccl::inet-host-name (host-to-hbo address))))
+
+(defmethod get-local-name ((usocket usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (values (get-peer-address usocket)
+ (get-peer-port usocket)))
+
+(defmethod get-local-address ((usocket usocket))
+ (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) ""))))
+
+(defmethod get-local-port ((usocket usocket))
+ (local-port (socket usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket)))))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (remote-port (socket usocket)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASIC MCL SOCKET IMPLEMENTATION
+
+(require :opentransport)
+
+(defclass socket ()
+ ((local-port :reader local-port :initarg :local-port)
+ (local-host :reader local-host :initarg :local-host)
+ (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type)))
+
+(defclass active-socket (socket)
+ ((remote-host :reader remote-host :initarg :remote-host)
+ (remote-port :reader remote-port :initarg :remote-port)
+ (deadline :initarg :deadline)
+ (nodelay :initarg :nodelay)
+ (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout
+ :type (or null fixnum) :documentation "ticks (60th of a second)")))
+
+(defmethod socket-open-stream ((socket active-socket))
+ (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket)
+ :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte)
+ :connect-timeout (connect-timeout socket)))
+
+(defmethod socket-close ((socket active-socket))
+ NIL)
+
+(defclass passive-socket (socket)
+ ((streams :accessor socket-streams :type list :initform NIL
+ :documentation "Circular list of streams with first element the next to open")
+ (reuse-address :reader reuse-address :initarg :reuse-address)))
+
+(defmethod initialize-instance :after ((socket passive-socket) &key backlog)
+ (loop repeat backlog
+ collect (socket-open-listener socket) into streams
+ finally (setf (socket-streams socket)
+ (cdr (rplacd (last streams) streams))))
+ (when (zerop (local-port socket))
+ (setf (slot-value socket 'local-port)
+ (or (ccl::process-wait-with-timeout "binding port" (* 10 60)
+ #'ccl::stream-local-port (car (socket-streams socket)))
+ (error "timeout")))))
+
+(defmethod socket-accept ((socket passive-socket) &key element-type)
+ (flet ((connection-established-p (stream)
+ (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
+ (let ((state (ccl::opentransport-stream-connection-state stream)))
+ (not (eq :unbnd state))))))
+ (with-mapped-conditions ()
+ (let* ((new (socket-open-listener socket element-type))
+ (connection (car (socket-streams socket))))
+ (assert connection)
+ (rplaca (socket-streams socket) new)
+ (setf (socket-streams socket)
+ (cdr (socket-streams socket)))
+ (ccl::process-wait "Socket Accept" #'connection-established-p connection) ; expensive polling...
+ connection))))
+
+(defmethod socket-close ((socket passive-socket))
+ (loop
+ with streams = (socket-streams socket)
+ for (stream tail) on streams
+ do (close stream :abort T)
+ until (eq tail streams)
+ finally (setf (socket-streams socket) NIL)))
+
+(defmethod socket-open-listener (socket &optional element-type)
+ ; see http://code.google.com/p/mcl/issues/detail?id=28
+ (let* ((ccl::*passive-interface-address* (local-host socket))
+ (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress)
+ :reuse-local-port-p (reuse-address socket)
+ :element-type (if (subtypep (or element-type (element-type socket))
+ 'character)
+ 'ccl::base-character
+ 'unsigned-byte))))
+ (declare (special ccl::*passive-interface-address*))
+ new))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+#| TEST (from test-usocket.lisp)
+
+
+(defparameter +non-existing-host+ "192.168.1.1")
+(defparameter +unused-local-port+ 15213)
+(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket
+ :stream :my-stream))
+(defparameter +common-lisp-net+ #(208 72 159 207)) ;; common-lisp.net IP
+
+
+(usocket:socket *soc1*)
+
+(usocket:socket-connect "127.0.0.0" +unused-local-port+)
+
+(usocket:socket-connect #(127 0 0 0) +unused-local-port+)
+
+(usocket:socket-connect 2130706432 +unused-local-port+)
+
+ (let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+ (unwind-protect
+ (typep sock 'usocket:usocket)
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+ (unwind-protect
+ (typep sock 'usocket:usocket)
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80)))
+ (unwind-protect
+ (typep sock 'usocket:usocket)
+ (usocket:socket-close sock)))
+
+(let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+ (unwind-protect
+ (progn
+ (format (usocket:socket-stream sock)
+ "GET / HTTP/1.0~A~A~A~A"
+ #\Return #\Linefeed #\Return #\Linefeed)
+ (force-output (usocket:socket-stream sock))
+ (read-line (usocket:socket-stream sock)))
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+ (unwind-protect
+ (usocket::get-peer-address sock)
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+ (unwind-protect
+ (usocket::get-peer-port sock)
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+ (unwind-protect
+ (usocket::get-peer-name sock)
+ (usocket:socket-close sock)))
+
+ (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+ (unwind-protect
+ (usocket::get-local-address sock)
+ (usocket:socket-close sock)))
+
+|#
+
+
+#|
+
+(defun socket-server (host port)
+ (let ((socket (socket-listen host port)))
+ (unwind-protect
+ (loop
+ (with-open-stream (stream (socket-stream (socket-accept socket)))
+ (ccl::telnet-write-line stream "~A"
+ (reverse (ccl::telnet-read-line stream)))
+ (ccl::force-output stream)))
+ (close socket))))
+
+(ccl::process-run-function "Socket Server" #'socket-server NIL 4088)
+
+(let* ((sock (socket-connect nil 4088))
+ (stream (usocket:socket-stream sock)))
+ (assert (streamp stream))
+ (ccl::telnet-write-line stream "hello ~A" (random 10))
+ (ccl::force-output stream)
+ (ccl::telnet-read-line stream))
+
+|#
More information about the usocket-cvs
mailing list