1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: sockets.lisp
6 ;;;; Purpose: Socket functions
7 ;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve
8 ;;;; Date Started: Jun 2003
10 ;;;; $Id: sockets.lisp,v 1.1 2003/07/08 16:12:40 kevin Exp $
11 ;;;; *************************************************************************
20 (define-condition lw-stream-error (error)
21 ((stream :initarg :stream
22 :reader stream-error-stream)
23 (action :initarg :action
24 :reader stream-error-action)
26 :reader stream-error-code)
27 (identifier :initarg :identifier
28 :reader stream-error-identifier))
29 (:report (lambda (condition stream)
30 (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
31 (stream-error-action condition)
32 (stream-error-identifier condition)
33 (stream-error-code condition)
34 (stream-error-stream condition)))))
36 (define-condition socket-error (lw-stream-error)
38 (:report (lambda (condition stream)
39 (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
40 (stream-error-action condition)
41 (stream-error-identifier condition)
42 (stream-error-code condition)
43 (stream-error-stream condition)))))
46 ((passive-socket :type fixnum
47 :initarg :passive-socket
48 :reader socket-os-fd)))
50 (defclass passive-socket (socket)
51 ((element-type :type (member signed-byte unsigned-byte base-char)
52 :initarg :element-type
58 (defmethod print-object ((passive-socket passive-socket) stream)
59 (print-unreadable-object (passive-socket stream :type t :identity nil)
60 (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
62 (defclass binary-socket-stream (comm:socket-stream) ())
63 (defclass input-binary-socket-stream (binary-socket-stream)())
64 (defclass output-binary-socket-stream (binary-socket-stream)())
65 (defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
68 (defun %socket-error-identifier (code)
72 (99 :address-not-available)
75 (103 :connection-aborted)
76 (104 :connection-reset)
77 (105 :no-buffer-space)
79 (110 :connection-timed-out)
80 (111 :connection-refused)
82 (113 :host-unreachable)
83 (otherwise :unknown)))
86 (defun %socket-error-identifier (code)
88 (10048 :address-in-use)
89 (10049 :address-not-available)
91 (10052 :network-reset)
92 (10053 :connection-aborted)
93 (10054 :connection-reset)
94 (10055 :no-buffer-space)
96 (10060 :connection-timed-out)
97 (10061 :connection-refused)
99 (10065 :host-unreachable)
100 (otherwise :unknown)))
102 (defun socket-error (stream error-code action format-string &rest format-args)
103 (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
104 (error 'socket-error :stream stream :code code
105 :identifier (if (keywordp error-code)
107 (%socket-error-identifier error-code))
109 :format-control "~A occured while doing socket IO (~?)"
110 :format-arguments (list 'socket-error format-string format-args))))
113 (defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
114 (apply #'socket-error stream error-code :IO format-string format-args))
116 (defmethod stream-input-available ((fd fixnum))
117 (comm::socket-listen fd))
119 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
120 (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
122 (defmethod stream-input-available ((stream comm:socket-stream))
123 (or (comm::socket-listen (comm:socket-stream-socket stream))
126 (defmethod stream-input-available ((stream passive-socket))
127 (comm::socket-listen (socket-os-fd stream)))
129 (defun %new-passive-socket (local-port)
130 (multiple-value-bind (socket error-location error-code)
131 (comm::create-tcp-socket-for-service local-port)
132 (cond (socket socket)
133 (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
138 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
139 "Create, bind and listen to an inet socket on *:PORT.
140 setsockopt SO_REUSEADDR if :reuse is not nil"
141 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
145 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
146 (sb-bsd-sockets:socket-bind
147 socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
148 (sb-bsd-sockets:socket-listen socket 15)
151 (defun create-inet-listener (port &key (format :text) (reuse-address t))
152 #+cmu (ext:create-inet-listener port)
154 (socket:make-socket :connect :passive :local-port port :format :binary
158 (if (or (null port) (integerp port))
160 (error "illegal value for port: ~s" port)))
161 :reuse-address reuse-address)
163 (listen-to-inet-port :port port :reuse reuse-address)
164 #+clisp (ext:socket-server port)
166 (let ((comm::*use_so_reuseaddr* reuse-address))
167 (make-instance 'passive-socket
169 :passive-socket (%new-passive-socket port)
170 :element-type (case format
171 (:text 'base-char))))
174 (defun make-fd-stream (socket &key input output element-type)
176 (sys:make-fd-stream socket :input input :output output
177 :element-type element-type)
179 (sb-bsd-sockets:socket-make-stream socket :input input :output output
180 :element-type element-type)
181 #-(or cmu sbcl) (declare (ignore input output element-type))
182 #-(or cmu sbcl) socket
186 (defun accept-tcp-connection (listener)
189 (mp:process-wait-until-fd-usable listener :input)
191 (nth-value 0 (ext:accept-tcp-connection listener))
194 (when (sb-sys:wait-until-fd-usable
195 (sb-bsd-sockets:socket-file-descriptor listener) :input)
196 (sb-bsd-sockets:socket-make-stream
197 (sb-bsd-sockets:socket-accept listener)
198 :element-type 'base-char
201 (socket:accept-connection listener)
203 (ext:socket-accept listener)
206 (loop while (not (stream-input-available listener))
208 (make-instance 'bidirectional-binary-socket-stream
209 :socket (comm::get-fd-from-socket
210 (socket-os-fd listener))
212 :element-type (element-type listener)))
217 (defmacro errorset (form display)
221 (declare (ignorable e))
223 (format t "~&Error: ~A~%" e)))))
225 (defun close-passive-socket (socket)
226 #+allegro (close socket)
227 #+cmu (unix:unix-close socket)
228 #+sbcl (sb-unix:unix-close
229 (sb-bsd-sockets:socket-file-descriptor socket))
230 #+clisp (close socket)
231 #+lispworks (comm::close-socket (socket-os-fd socket))
235 (defun close-active-socket (socket)
239 (defun ipaddr-to-dotted (ipaddr &key values)
240 "Convert from 32-bit integer to dotted string."
241 (declare (type (unsigned-byte 32) ipaddr))
242 (let ((a (logand #xff (ash ipaddr -24)))
243 (b (logand #xff (ash ipaddr -16)))
244 (c (logand #xff (ash ipaddr -8)))
245 (d (logand #xff ipaddr)))
248 (format nil "~d.~d.~d.~d" a b c d))))
251 (defun dotted-to-ipaddr (dotted &key (errorp t))
252 "Convert from dotted string to 32-bit integer."
253 (declare (string dotted))
255 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
256 (+ (ash (first ll) 24) (ash (second ll) 16)
257 (ash (third ll) 8) (fourth ll)))
259 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
260 (+ (ash (first ll) 24) (ash (second ll) 16)
261 (ash (third ll) 8) (fourth ll))))))
264 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
266 (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
267 (sb-bsd-sockets:host-ent-name
268 (sb-bsd-sockets:get-host-by-address
269 (sb-bsd-sockets:make-inet-address ipaddr))))
272 (defun lookup-hostname (host &key ignore-cache)
274 (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
276 (sb-bsd-sockets:host-ent-address
277 (sb-bsd-sockets:get-host-by-name host))
278 (dotted-to-ipaddr (ipaddr-to-dotted host))))
281 (defun make-active-socket (server port)
282 #+allegro (socket:make-socket :remote-host server
284 #+lispworks (comm:open-tcp-stream server port)
285 #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
288 (sb-bsd-sockets:socket-connect
289 socket (lookup-hostname server) port)
290 (sb-bsd-sockets:socket-make-stream socket
293 :element-type 'base-char))
295 (sys:make-fd-stream (ext:connect-to-inet-socket host port)
296 :input t :output t :element-type 'base-char)