X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=sockets.lisp;h=a75d77dfe38953b56aa35a34aa10c21b7c5ba917;hp=116e15537ce2315c7c94bb334128a069136c5f48;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=7a31a7ff629ae760d9c3e3abedf6e03605f83f23 diff --git a/sockets.lisp b/sockets.lisp index 116e155..a75d77d 100644 --- a/sockets.lisp +++ b/sockets.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -6,211 +6,94 @@ ;;;; Purpose: Socket functions ;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve ;;;; Date Started: Jun 2003 -;;;; -;;;; $Id: sockets.lisp,v 1.1 2003/07/08 16:12:40 kevin Exp $ ;;;; ************************************************************************* (in-package #:kmrcl) -;; Sockets - -#+lispworks -(progn - -(define-condition lw-stream-error (error) - ((stream :initarg :stream - :reader stream-error-stream) - (action :initarg :action - :reader stream-error-action) - (code :initarg :code - :reader stream-error-code) - (identifier :initarg :identifier - :reader stream-error-identifier)) - (:report (lambda (condition stream) - (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." - (stream-error-action condition) - (stream-error-identifier condition) - (stream-error-code condition) - (stream-error-stream condition))))) - -(define-condition socket-error (lw-stream-error) - () - (:report (lambda (condition stream) - (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." - (stream-error-action condition) - (stream-error-identifier condition) - (stream-error-code condition) - (stream-error-stream condition))))) - -(defclass socket () - ((passive-socket :type fixnum - :initarg :passive-socket - :reader socket-os-fd))) - - (defclass passive-socket (socket) - ((element-type :type (member signed-byte unsigned-byte base-char) - :initarg :element-type - :reader element-type) - (port :type fixnum - :initarg :port - :reader local-port))) - - (defmethod print-object ((passive-socket passive-socket) stream) - (print-unreadable-object (passive-socket stream :type t :identity nil) - (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket)))) - - (defclass binary-socket-stream (comm:socket-stream) ()) -(defclass input-binary-socket-stream (binary-socket-stream)()) -(defclass output-binary-socket-stream (binary-socket-stream)()) -(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)()) - -#+unix -(defun %socket-error-identifier (code) - (case code - (32 :x-broken-pipe) - (98 :address-in-use) - (99 :address-not-available) - (100 :network-down) - (102 :network-reset) - (103 :connection-aborted) - (104 :connection-reset) - (105 :no-buffer-space) - (108 :shutdown) - (110 :connection-timed-out) - (111 :connection-refused) - (112 :host-down) - (113 :host-unreachable) - (otherwise :unknown))) - -#+win32 -(defun %socket-error-identifier (code) - (case code - (10048 :address-in-use) - (10049 :address-not-available) - (10050 :network-down) - (10052 :network-reset) - (10053 :connection-aborted) - (10054 :connection-reset) - (10055 :no-buffer-space) - (10058 :shutdown) - (10060 :connection-timed-out) - (10061 :connection-refused) - (10064 :host-down) - (10065 :host-unreachable) - (otherwise :unknown))) - -(defun socket-error (stream error-code action format-string &rest format-args) - (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value)))) - (error 'socket-error :stream stream :code code - :identifier (if (keywordp error-code) - error-code - (%socket-error-identifier error-code)) - :action action - :format-control "~A occured while doing socket IO (~?)" - :format-arguments (list 'socket-error format-string format-args)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (require :sb-bsd-sockets) + #+lispworks (require "comm") + #+allegro (require :socket)) -(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args) - (apply #'socket-error stream error-code :IO format-string format-args)) - -(defmethod stream-input-available ((fd fixnum)) - (comm::socket-listen fd)) - -(defmethod stream-input-available ((stream stream::os-file-handle-stream)) - (stream-input-available (stream::os-file-handle-stream-file-handle stream))) - -(defmethod stream-input-available ((stream comm:socket-stream)) - (or (comm::socket-listen (comm:socket-stream-socket stream)) - (listen stream))) - -(defmethod stream-input-available ((stream passive-socket)) - (comm::socket-listen (socket-os-fd stream))) - -(defun %new-passive-socket (local-port) - (multiple-value-bind (socket error-location error-code) - (comm::create-tcp-socket-for-service local-port) - (cond (socket socket) - (t (error 'socket-error :action error-location :code error-code :identifier :unknown))))) - -) ;; lispworks - #+sbcl (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil)) "Create, bind and listen to an inet socket on *:PORT. setsockopt SO_REUSEADDR if :reuse is not nil" + (declare (ignore kind)) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) + :type :stream + :protocol :tcp))) (if reuse (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) - (sb-bsd-sockets:socket-bind + (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port) (sb-bsd-sockets:socket-listen socket 15) socket)) (defun create-inet-listener (port &key (format :text) (reuse-address t)) + #+cmu (declare (ignore format reuse-address)) #+cmu (ext:create-inet-listener port) #+allegro - (socket:make-socket :connect :passive :local-port port :format :binary - :address-family - (if (stringp port) - :file - (if (or (null port) (integerp port)) - :internet - (error "illegal value for port: ~s" port))) - :reuse-address reuse-address) - #+sbcl - (listen-to-inet-port :port port :reuse reuse-address) + (socket:make-socket :connect :passive :local-port port :format format + :address-family + (if (stringp port) + :file + (if (or (null port) (integerp port)) + :internet + (error "illegal value for port: ~s" port))) + :reuse-address reuse-address) + #+sbcl (declare (ignore format)) + #+sbcl (listen-to-inet-port :port port :reuse reuse-address) + #+clisp (declare (ignore format reuse-address)) #+clisp (ext:socket-server port) - #+lispworks - (let ((comm::*use_so_reuseaddr* reuse-address)) - (make-instance 'passive-socket - :port port - :passive-socket (%new-passive-socket port) - :element-type (case format - (:text 'base-char)))) + #+openmcl + (declare (ignore format)) + #+openmcl + (ccl:make-socket :connect :passive :local-port port + :reuse-address reuse-address) + #-(or allegro clisp cmu sbcl openmcl) + (warn "create-inet-listener not supported on this implementation") ) (defun make-fd-stream (socket &key input output element-type) #+cmu (sys:make-fd-stream socket :input input :output output - :element-type element-type) + :element-type element-type) #+sbcl (sb-bsd-sockets:socket-make-stream socket :input input :output output - :element-type element-type) + :element-type element-type) #-(or cmu sbcl) (declare (ignore input output element-type)) #-(or cmu sbcl) socket ) (defun accept-tcp-connection (listener) + "Returns (VALUES stream socket)" + #+allegro + (let ((sock (socket:accept-connection listener))) + (values sock sock)) + #+clisp + (let ((sock (ext:socket-accept listener))) + (values sock sock)) #+cmu (progn (mp:process-wait-until-fd-usable listener :input) - (sys:make-fd-stream - (nth-value 0 (ext:accept-tcp-connection listener)) - :input t :output t)) + (let ((sock (nth-value 0 (ext:accept-tcp-connection listener)))) + (values (sys:make-fd-stream sock :input t :output t) sock))) #+sbcl (when (sb-sys:wait-until-fd-usable - (sb-bsd-sockets:socket-file-descriptor listener) :input) - (sb-bsd-sockets:socket-make-stream - (sb-bsd-sockets:socket-accept listener) - :element-type 'base-char - :input t :output t)) - #+allegro - (socket:accept-connection listener) - #+clisp - (ext:socket-accept listener) - #+lispworks - (progn - (loop while (not (stream-input-available listener)) - do (sleep 1)) - (make-instance 'bidirectional-binary-socket-stream - :socket (comm::get-fd-from-socket - (socket-os-fd listener)) - :direction :io - :element-type (element-type listener))) - + (sb-bsd-sockets:socket-file-descriptor listener) :input) + (let ((sock (sb-bsd-sockets:socket-accept listener))) + (values + (sb-bsd-sockets:socket-make-stream + sock :element-type :default :input t :output t) + sock))) + #+openmcl + (let ((sock (ccl:accept-connection listener :wait t))) + (values sock sock)) + #-(or allegro clisp cmu sbcl openmcl) + (warn "accept-tcp-connection not supported on this implementation") ) @@ -224,41 +107,46 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (defun close-passive-socket (socket) #+allegro (close socket) + #+clisp (ext:socket-server-close socket) #+cmu (unix:unix-close socket) #+sbcl (sb-unix:unix-close - (sb-bsd-sockets:socket-file-descriptor socket)) - #+clisp (close socket) - #+lispworks (comm::close-socket (socket-os-fd socket)) + (sb-bsd-sockets:socket-file-descriptor socket)) + #+openmcl (close socket) + #-(or allegro clisp cmu sbcl openmcl) + (warn "close-passive-socket not supported on this implementation") ) (defun close-active-socket (socket) - (close socket)) + #+sbcl (sb-bsd-sockets:socket-close socket) + #-sbcl (close socket)) -#+sbcl (defun ipaddr-to-dotted (ipaddr &key values) "Convert from 32-bit integer to dotted string." (declare (type (unsigned-byte 32) ipaddr)) (let ((a (logand #xff (ash ipaddr -24))) - (b (logand #xff (ash ipaddr -16))) - (c (logand #xff (ash ipaddr -8))) - (d (logand #xff ipaddr))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) (if values - (values a b c d) + (values a b c d) (format nil "~d.~d.~d.~d" a b c d)))) -#+sbcl (defun dotted-to-ipaddr (dotted &key (errorp t)) "Convert from dotted string to 32-bit integer." (declare (string dotted)) (if errorp - (let ((ll (string-tokens (substitute #\Space #\. dotted)))) - (+ (ash (first ll) 24) (ash (second ll) 16) - (ash (third ll) 8) (fourth ll))) + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll)))) (ignore-errors - (let ((ll (string-tokens (substitute #\Space #\. dotted)))) - (+ (ash (first ll) 24) (ash (second ll) 16) - (ash (third ll) 8) (fourth ll)))))) + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll))))))) #+sbcl (defun ipaddr-to-hostname (ipaddr &key ignore-cache) @@ -279,19 +167,52 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (defun make-active-socket (server port) - #+allegro (socket:make-socket :remote-host server - :remote-port port) - #+lispworks (comm:open-tcp-stream server port) - #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) - (sb-bsd-sockets:socket-connect - socket (lookup-hostname server) port) - (sb-bsd-sockets:socket-make-stream socket - :input t - :output t - :element-type 'base-char)) - #+cmu - (sys:make-fd-stream (ext:connect-to-inet-socket host port) - :input t :output t :element-type 'base-char) + "Returns (VALUES STREAM SOCKET)" + #+allegro + (let ((sock (socket:make-socket :remote-host server + :remote-port port))) + (values sock sock)) + #+lispworks + (let ((sock (comm:open-tcp-stream server port))) + (values sock sock)) + #+sbcl + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port) + (values + (sb-bsd-sockets:socket-make-stream + sock :input t :output t :element-type :default) + sock)) + #+cmu + (let ((sock (ext:connect-to-inet-socket server port))) + (values + (sys:make-fd-stream sock :input t :output t :element-type 'base-char) + sock)) + #+clisp + (let ((sock (ext:socket-connect port server))) + (values sock sock)) + #+openmcl + (let ((sock (ccl:make-socket :remote-host server :remote-port port ))) + (values sock sock)) + ) + +(defun ipaddr-array-to-dotted (array) + (format nil "~{~D~^.~}" (coerce array 'list)) + #+ignore + (format nil "~D.~D.~D.~D" + (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array))) + +(defun remote-host (socket) + #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket)) + #+lispworks (nth-value 0 (comm:get-socket-peer-address socket)) + #+sbcl (ipaddr-array-to-dotted + (nth-value 0 (sb-bsd-sockets:socket-peername socket))) + #+cmu (nth-value 0 (ext:get-peer-host-and-port socket)) + #+clisp (let* ((peer (ext:socket-stream-peer socket t)) + (stop (position #\Space peer))) + ;; 2.37-2.39 had do-not-resolve-p backwards + (if stop (subseq peer 0 stop) peer)) + #+openmcl (ccl:remote-host socket) ) +