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.2 2003/07/09 22:12:52 kevin Exp $
11 ;;;; *************************************************************************
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 #+sbcl (require :sb-bsd-sockets)
17 #+lispworks (require "comm")
18 #+allegro (require :socket))
24 (define-condition lw-stream-error (error)
25 ((stream :initarg :stream
26 :reader stream-error-stream)
27 (action :initarg :action
28 :reader stream-error-action)
30 :reader stream-error-code)
31 (identifier :initarg :identifier
32 :reader stream-error-identifier))
33 (:report (lambda (condition stream)
34 (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
35 (stream-error-action condition)
36 (stream-error-identifier condition)
37 (stream-error-code condition)
38 (stream-error-stream condition)))))
40 (define-condition socket-error (lw-stream-error)
42 (:report (lambda (condition stream)
43 (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
44 (stream-error-action condition)
45 (stream-error-identifier condition)
46 (stream-error-code condition)
47 (stream-error-stream condition)))))
50 ((passive-socket :type fixnum
51 :initarg :passive-socket
52 :reader socket-os-fd)))
54 (defclass passive-socket (socket)
55 ((element-type :type (member signed-byte unsigned-byte base-char)
56 :initarg :element-type
62 (defmethod print-object ((passive-socket passive-socket) stream)
63 (print-unreadable-object (passive-socket stream :type t :identity nil)
64 (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
66 (defclass binary-socket-stream (comm:socket-stream) ())
67 (defclass input-binary-socket-stream (binary-socket-stream)())
68 (defclass output-binary-socket-stream (binary-socket-stream)())
69 (defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
72 (defun %socket-error-identifier (code)
76 (99 :address-not-available)
79 (103 :connection-aborted)
80 (104 :connection-reset)
81 (105 :no-buffer-space)
83 (110 :connection-timed-out)
84 (111 :connection-refused)
86 (113 :host-unreachable)
87 (otherwise :unknown)))
90 (defun %socket-error-identifier (code)
92 (10048 :address-in-use)
93 (10049 :address-not-available)
95 (10052 :network-reset)
96 (10053 :connection-aborted)
97 (10054 :connection-reset)
98 (10055 :no-buffer-space)
100 (10060 :connection-timed-out)
101 (10061 :connection-refused)
103 (10065 :host-unreachable)
104 (otherwise :unknown)))
106 (defun socket-error (stream error-code action format-string &rest format-args)
107 (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
108 (error 'socket-error :stream stream :code code
109 :identifier (if (keywordp error-code)
111 (%socket-error-identifier error-code))
113 :format-control "~A occured while doing socket IO (~?)"
114 :format-arguments (list 'socket-error format-string format-args))))
117 (defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
118 (apply #'socket-error stream error-code :IO format-string format-args))
120 (defmethod stream-input-available ((fd fixnum))
121 (comm::socket-listen fd))
123 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
124 (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
126 (defmethod stream-input-available ((stream comm:socket-stream))
127 (or (comm::socket-listen (comm:socket-stream-socket stream))
130 (defmethod stream-input-available ((stream passive-socket))
131 (comm::socket-listen (socket-os-fd stream)))
133 (defun %new-passive-socket (local-port)
134 (multiple-value-bind (socket error-location error-code)
135 (comm::create-tcp-socket-for-service local-port)
136 (cond (socket socket)
137 (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
142 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
143 "Create, bind and listen to an inet socket on *:PORT.
144 setsockopt SO_REUSEADDR if :reuse is not nil"
145 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
149 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
150 (sb-bsd-sockets:socket-bind
151 socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
152 (sb-bsd-sockets:socket-listen socket 15)
155 (defun create-inet-listener (port &key (format :text) (reuse-address t))
156 #+cmu (ext:create-inet-listener port)
158 (socket:make-socket :connect :passive :local-port port :format :binary
162 (if (or (null port) (integerp port))
164 (error "illegal value for port: ~s" port)))
165 :reuse-address reuse-address)
167 (listen-to-inet-port :port port :reuse reuse-address)
168 #+clisp (ext:socket-server port)
170 (let ((comm::*use_so_reuseaddr* reuse-address))
171 (make-instance 'passive-socket
173 :passive-socket (%new-passive-socket port)
174 :element-type (case format
175 (:text 'base-char))))
178 (defun make-fd-stream (socket &key input output element-type)
180 (sys:make-fd-stream socket :input input :output output
181 :element-type element-type)
183 (sb-bsd-sockets:socket-make-stream socket :input input :output output
184 :element-type element-type)
185 #-(or cmu sbcl) (declare (ignore input output element-type))
186 #-(or cmu sbcl) socket
190 (defun accept-tcp-connection (listener)
193 (mp:process-wait-until-fd-usable listener :input)
195 (nth-value 0 (ext:accept-tcp-connection listener))
198 (when (sb-sys:wait-until-fd-usable
199 (sb-bsd-sockets:socket-file-descriptor listener) :input)
200 (sb-bsd-sockets:socket-make-stream
201 (sb-bsd-sockets:socket-accept listener)
202 :element-type 'base-char
205 (socket:accept-connection listener)
207 (ext:socket-accept listener)
210 (loop while (not (stream-input-available listener))
212 (make-instance 'bidirectional-binary-socket-stream
213 :socket (comm::get-fd-from-socket
214 (socket-os-fd listener))
216 :element-type (element-type listener)))
221 (defmacro errorset (form display)
225 (declare (ignorable e))
227 (format t "~&Error: ~A~%" e)))))
229 (defun close-passive-socket (socket)
230 #+allegro (close socket)
231 #+cmu (unix:unix-close socket)
232 #+sbcl (sb-unix:unix-close
233 (sb-bsd-sockets:socket-file-descriptor socket))
234 #+clisp (close socket)
235 #+lispworks (comm::close-socket (socket-os-fd socket))
239 (defun close-active-socket (socket)
243 (defun ipaddr-to-dotted (ipaddr &key values)
244 "Convert from 32-bit integer to dotted string."
245 (declare (type (unsigned-byte 32) ipaddr))
246 (let ((a (logand #xff (ash ipaddr -24)))
247 (b (logand #xff (ash ipaddr -16)))
248 (c (logand #xff (ash ipaddr -8)))
249 (d (logand #xff ipaddr)))
252 (format nil "~d.~d.~d.~d" a b c d))))
255 (defun dotted-to-ipaddr (dotted &key (errorp t))
256 "Convert from dotted string to 32-bit integer."
257 (declare (string dotted))
259 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
260 (+ (ash (first ll) 24) (ash (second ll) 16)
261 (ash (third ll) 8) (fourth ll)))
263 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
264 (+ (ash (first ll) 24) (ash (second ll) 16)
265 (ash (third ll) 8) (fourth ll))))))
268 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
270 (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
271 (sb-bsd-sockets:host-ent-name
272 (sb-bsd-sockets:get-host-by-address
273 (sb-bsd-sockets:make-inet-address ipaddr))))
276 (defun lookup-hostname (host &key ignore-cache)
278 (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
280 (sb-bsd-sockets:host-ent-address
281 (sb-bsd-sockets:get-host-by-name host))
282 (dotted-to-ipaddr (ipaddr-to-dotted host))))
285 (defun make-active-socket (server port)
286 #+allegro (socket:make-socket :remote-host server
288 #+lispworks (comm:open-tcp-stream server port)
289 #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
292 (sb-bsd-sockets:socket-connect
293 socket (lookup-hostname server) port)
294 (sb-bsd-sockets:socket-make-stream socket
297 :element-type 'base-char))
299 (sys:make-fd-stream (ext:connect-to-inet-socket host port)
300 :input t :output t :element-type 'base-char)