Author: ctian Date: Mon Jul 12 05:47:40 2010 New Revision: 542
Log: Server: improved SOCKET-SERVER, for both TCP and UDP now.
Added: usocket/trunk/vendor/spawn-thread.lisp (contents, props changed) Modified: usocket/trunk/backend/lispworks.lisp usocket/trunk/package.lisp usocket/trunk/server.lisp usocket/trunk/usocket.asd
Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Mon Jul 12 05:47:40 2010 @@ -298,10 +298,10 @@ (:datagram (let ((usocket (make-datagram-socket (if (and host port) - (connect-to-udp-server host port - :local-address local-host + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) :local-port local-port) - (open-udp-socket :local-address local-host + (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) :local-port local-port)) :connected-p t))) (hcl:flag-special-free-action usocket)
Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Mon Jul 12 05:47:40 2010 @@ -80,3 +80,19 @@ #:insufficient-implementation ; conditions regarding usocket support level #:unsupported #:unimplemented)) + +(in-package :usocket) + +;;; Logical Pathname Translations, learn from CL-HTTP source code +(eval-when (:load-toplevel :execute) + (let* ((defaults #+asdf (asdf:component-pathname (asdf:find-system :usocket)) + #-asdf *load-truename*) + (home (make-pathname :name :wild :type :wild + :directory (append (pathname-directory defaults) + '(:wild-inferiors)) + :host (pathname-host defaults) + :defaults defaults + :version :newest))) + (setf (logical-pathname-translations "usocket") + `(("**;*.*.newest" ,home) + ("**;*.*" ,home)))))
Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Mon Jul 12 05:47:40 2010 @@ -3,43 +3,96 @@
(in-package :usocket)
+(defun socket-server (host port function &optional arguments + &key in-new-thread (protocol :stream) + ;; for udp + (timeout 1) (max-buffer-size +max-datagram-packet-size+) + ;; for tcp + element-type reuse-address multi-threading) + (let* ((real-host (or host #(0 0 0 0))) + (socket (ecase protocol + (:stream + (apply #'socket-listen + `(,real-host ,port + ,@(when element-type `(:element-type ,element-type)) + ,@(when reuse-address `(:reuse-address ,reuse-address))))) + (:datagram + (socket-connect nil nil :protocol :datagram + :local-host real-host + :local-port port))))) + (labels ((real-call () + (ecase protocol + (:stream + (tcp-event-loop socket function arguments + :element-type element-type + :multi-threading multi-threading)) + (:datagram + (udp-event-loop socket function arguments + :timeout timeout + :max-buffer-size max-buffer-size))))) + (if in-new-thread + (spawn-thread "USOCKET Server" #'real-call) + (real-call))))) + (defvar *remote-host*) (defvar *remote-port*)
-(defun socket-server (host port function &optional arguments - &key (timeout 1) - (max-buffer-size +max-datagram-packet-size+)) - (let ((socket (socket-connect nil nil - :protocol :datagram - :local-host host - :local-port port)) - (buffer (make-array max-buffer-size - :element-type '(unsigned-byte 8) - :initial-element 0))) +(defun default-udp-handler (buffer) ; echo + (declare (type (simple-array (unsigned-byte 8) *) buffer)) + buffer) + +(defun udp-event-loop (socket function &optional arguments + &key timeout max-buffer-size) + (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0)) + (sockets (list socket))) + (unwind-protect + (loop do + (multiple-value-bind (return-sockets real-time) + (wait-for-input sockets :timeout timeout) + (declare (ignore return-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 (subseq buffer 0 n) arguments))) + (when reply + (replace buffer reply) + (let ((n (socket-send socket buffer (length reply) + :host *remote-host* + :port *remote-port*))) + (when (minusp n) + (error "send error: ~A~%" n)))))) + (error "receive error: ~A" n)))) + #+scl (when thread:*quitting-lisp* (return)) + #+(and cmu mp) (mp:process-yield)))) + (socket-close socket) + (values))) + +(defun default-tcp-handler (stream) ; null + (declare (type stream stream)) + (terpri stream)) + +(defun tcp-event-loop (socket function &optional arguments + &key element-type multi-threading) + (let ((real-function #'(lambda (client-socket &rest arguments) + (unwind-protect + (apply function (socket-stream client-socket) arguments) + (close (socket-stream client-socket)) + (socket-close client-socket))))) (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) - :host *remote-host* - :port *remote-port*))) - (when (minusp n) - (error "send error: ~A~%" n)))))) - (error "receive error: ~A" n)))) - #+scl (when thread:*quitting-lisp* - (return)) - #+(and cmu mp) (mp:process-yield)))) + (loop do + (let* ((client-socket (apply #'socket-accept + `(,socket ,@(when element-type `(:element-type ,element-type))))) + (client-stream (socket-stream client-socket))) + (if multi-threading + (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments) + (prog1 (apply real-function client-socket arguments) + (close client-stream) + (socket-close client-socket))) + #+scl (when thread:*quitting-lisp* (return)) + #+(and cmu mp) (mp:process-yield))) (socket-close socket) (values))))
Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Mon Jul 12 05:47:40 2010 @@ -22,7 +22,8 @@ (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") #+mcl (:file "kqueue") - #+clozure (:file "ccl-send"))) + #+openmcl (:file "ccl-send") + (:file "spawn-thread"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition")
Added: usocket/trunk/vendor/spawn-thread.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/spawn-thread.lisp Mon Jul 12 05:47:40 2010 @@ -0,0 +1,71 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; SPWAN-THREAD from GBBopen's PortableThreads.lisp + +(in-package :usocket) + +#+(and digitool ccl-5.1) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':digitool-mcl *features*)) + +;;; --------------------------------------------------------------------------- +;;; Add clozure feature to legacy OpenMCL: + +#+(and openmcl (not clozure)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':clozure *features*)) + +;;; =========================================================================== +;;; Features & warnings + +#+(or (and clisp (not mt)) + cormanlisp + (and cmu (not mp)) + (and ecl (not threads)) + gcl + (and sbcl (not sb-thread))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':threads-not-available *features*)) + +;;; --------------------------------------------------------------------------- + +#+threads-not-available +(defun threads-not-available (operation) + (warn "Threads are not available in ~a running on ~a; ~s was used." + (lisp-implementation-type) + (machine-type) + operation)) + +;;; =========================================================================== +;;; Spawn-Thread + +(defun spawn-thread (name function &rest args) + #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) + (declare (dynamic-extent args)) + #+allegro + (apply #'mp:process-run-function name function args) + #+(and clisp mt) + (mt:make-thread #'(lambda () (apply function args)) + :name name) + #+clozure + (apply #'ccl:process-run-function name function args) + #+(and cmu mp) + (mp:make-process #'(lambda () (apply function args)) + :name name) + #+digitool-mcl + (apply #'ccl:process-run-function name function args) + #+(and ecl threads) + (apply #'mp:process-run-function name function args) + #+lispworks + (apply #'mp:process-run-function name nil function args) + #+(and sbcl sb-thread) + (sb-thread:make-thread #'(lambda () (apply function args)) + :name name) + #+scl + (mp:make-process #'(lambda () (apply function args)) + :name name) + #+threads-not-available + (declare (ignore name function args)) + #+threads-not-available + (threads-not-available 'spawn-thread))