Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[10d2c0]: contrib / sb-bsd-sockets / sockets.lisp Maximize Restore History

Download this file

sockets.lisp    280 lines (239 with data), 11.6 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
(in-package "SB-BSD-SOCKETS")
;;;; Methods, classes, functions for sockets. Protocol-specific stuff
;;;; is deferred to inet.lisp, unix.lisp, etc
#|| <h2>SOCKETs</h2>
|#
(eval-when (:load-toplevel :compile-toplevel :execute)
(defclass socket ()
((file-descriptor :initarg :descriptor
:reader socket-file-descriptor)
(family :initform (error "No socket family") :reader socket-family)
(protocol :initarg :protocol :reader socket-protocol)
(type :initarg :type :reader socket-type)
(stream))))
(defmethod print-object ((object socket) stream)
(print-unreadable-object (object stream :type t :identity t)
(princ "descriptor " stream)
(princ (slot-value object 'file-descriptor) stream)))
(defmethod shared-initialize :after ((socket socket) slot-names
&key protocol type
&allow-other-keys)
(let* ((proto-num
(cond ((and protocol (keywordp protocol))
(get-protocol-by-name (string-downcase (symbol-name protocol))))
(protocol protocol)
(t 0)))
(fd (or (and (slot-boundp socket 'file-descriptor)
(socket-file-descriptor socket))
(sockint::socket (socket-family socket)
(ecase type
((:datagram) sockint::sock-dgram)
((:stream) sockint::sock-stream))
proto-num))))
(if (= fd -1) (socket-error "socket"))
(setf (slot-value socket 'file-descriptor) fd
(slot-value socket 'protocol) proto-num
(slot-value socket 'type) type)
(sb-ext:finalize socket (lambda () (sockint::close fd)))))
;; we deliberately redesign the "bind" interface: instead of passing a
;; sockaddr_something as second arg, we pass the elements of one as
;; multiple arguments.
(defgeneric socket-bind (socket &rest address))
(defmethod socket-bind ((socket socket)
&rest address)
"Bind SOCKET to ADDRESS, which may vary according to socket family. For
the INET family, pass ADDRESS and PORT as two arguments; for FILE address
family sockets, pass the filename string. See also bind(2)"
(let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
(if (= (sb-sys:without-gcing
(sockint::bind (socket-file-descriptor socket)
(sockint::array-data-address sockaddr)
(size-of-sockaddr socket)))
-1)
(socket-error "bind"))))
(defmethod socket-accept ((socket socket))
"Perform the accept(2) call, returning a newly-created connected socket
and the peer address as multiple values"
(let* ((sockaddr (make-sockaddr-for socket))
(fd (sb-sys:without-gcing
(sockint::accept (socket-file-descriptor socket)
(sockint::array-data-address sockaddr)
(size-of-sockaddr socket)))))
(apply #'values
(if (= fd -1)
(socket-error "accept")
(let ((s (make-instance (class-of socket)
:type (socket-type socket)
:protocol (socket-protocol socket)
:descriptor fd)))
(sb-ext:finalize s (lambda () (sockint::close fd)))))
(multiple-value-list (bits-of-sockaddr socket sockaddr)))))
(defgeneric socket-connect (socket &rest address))
(defmethod socket-connect ((socket socket) &rest peer)
"Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value"
(let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
(if (= (sb-sys:without-gcing
(sockint::connect (socket-file-descriptor socket)
(sockint::array-data-address sockaddr)
(size-of-sockaddr socket)))
-1)
(socket-error "connect") )))
(defmethod socket-peername ((socket socket))
"Return the socket's peer; depending on the address family this may return multiple values"
(let* ((sockaddr (make-sockaddr-for socket)))
(when (= (sb-sys:without-gcing
(sockint::getpeername (socket-file-descriptor socket)
(sockint::array-data-address sockaddr)
(size-of-sockaddr socket)))
-1)
(socket-error "getpeername"))
(bits-of-sockaddr socket sockaddr)))
(defmethod socket-name ((socket socket))
"Return the address (as vector of bytes) and port that the socket is bound to, as multiple values"
(let* ((sockaddr (make-sockaddr-for socket)))
(when (= (sb-sys:without-gcing
(sockint::getsockname (socket-file-descriptor socket)
(sockint::array-data-address sockaddr)
(size-of-sockaddr socket)))
-1)
(socket-error "getsockname"))
(bits-of-sockaddr socket sockaddr)))
;;; There are a whole bunch of interesting things you can do with a
;;; socket that don't really map onto "do stream io", especially in
;;; CL which has no portable concept of a "short read". socket-receive
;;; allows us to read from an unconnected socket into a buffer, and
;;; to learn who the sender of the packet was
(defmethod socket-receive ((socket socket) buffer length
&key
oob peek waitall
(element-type 'character))
"Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
used, so at least one of these two arguments must be non-NIL. If
BUFFER is supplied, it had better be of an element type one octet wide.
Returns the buffer, its length, and the address of the peer
that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
so that the actual packet length is returned even if the buffer was too
small"
(let ((flags
(logior (if oob sockint::MSG-OOB 0)
(if peek sockint::MSG-PEEK 0)
(if waitall sockint::MSG-WAITALL 0)
sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
(if (eql (socket-type socket) :datagram)
sockint::msg-TRUNC 0)))
(sockaddr (make-sockaddr-for socket)))
(unless (or buffer length)
(error "Must supply at least one of BUFFER or LENGTH"))
(unless buffer
(setf buffer (make-array length :element-type element-type)))
(sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
(setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
(sb-sys:without-gcing
(let ((len
(sockint::recvfrom (socket-file-descriptor socket)
(sockint::array-data-address buffer)
(or length (length buffer))
flags
(sockint::array-data-address sockaddr)
(sb-alien:cast sa-len (* integer)))))
(when (= len -1) (socket-error "recvfrom"))
(apply #'values buffer len (multiple-value-list
(bits-of-sockaddr socket sockaddr))))))))
(defmethod socket-listen ((socket socket) backlog)
"Mark SOCKET as willing to accept incoming connections. BACKLOG
defines the maximum length that the queue of pending connections may
grow to before new connection attempts are refused. See also listen(2)"
(let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
(if (= r -1)
(socket-error "listen"))))
(defmethod socket-close ((socket socket))
"Close SOCKET. May throw any kind of error that write(2) would have
thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
stream instead"
;; the close(2) manual page has all kinds of warning about not
;; checking the return value of close, on the grounds that an
;; earlier write(2) might have returned successfully w/o actually
;; writing the stuff to disk. It then goes on to define the only
;; possible error return as EBADF (fd isn't a valid open file
;; descriptor). Presumably this is an oversight and we could also
;; get anything that write(2) would have given us.
;; What we do: we catch EBADF. It should only ever happen if
;; (a) someone's closed the socket already (stream closing seems
;; to have this effect) or (b) the caller is messing around with
;; socket internals. That's not supported, dude
(if (slot-boundp socket 'stream)
(close (slot-value socket 'stream)) ;; closes socket as well
(handler-case
(if (= (sockint::close (socket-file-descriptor socket)) -1)
(socket-error "close"))
(bad-file-descriptor-error (c) (declare (ignore c)) nil)
(:no-error (c) (declare (ignore c)) nil))))
(defmethod socket-make-stream ((socket socket) &rest args)
"Find or create a STREAM that can be used for IO on SOCKET (which
must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM."
(let ((stream
(and (slot-boundp socket 'stream) (slot-value socket 'stream))))
(unless stream
(setf stream (apply #'sb-sys:make-fd-stream
(socket-file-descriptor socket) args))
(setf (slot-value socket 'stream) stream)
(sb-ext:cancel-finalization socket))
stream))
;;; Error handling
(define-condition socket-error (error)
((errno :initform nil
:initarg :errno
:reader socket-error-errno)
(symbol :initform nil :initarg :symbol :reader socket-error-symbol)
(syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall))
(:report (lambda (c s)
(let ((num (socket-error-errno c)))
(format s "Socket error in \"~A\": ~A (~A)"
(socket-error-syscall c)
(or (socket-error-symbol c) (socket-error-errno c))
#+cmu (sb-unix:get-unix-error-msg num)
#+sbcl (sb-int:strerror num))))))
;;; watch out for slightly hacky symbol punning: we use both the value
;;; and the symbol-name of sockint::efoo
(defmacro define-socket-condition (symbol name)
`(progn
(define-condition ,name (socket-error)
((symbol :reader socket-error-symbol :initform (quote ,symbol))))
(push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
(defparameter *conditions-for-errno* nil)
;;; this needs the rest of the list adding to it, really. They also
;;; need
;;; - conditions to be exported in the DEFPACKAGE form
;;; - symbols to be added to constants.ccon
;;; I haven't yet thought of a non-kludgey way of keeping all this in
;;; the same place
(define-socket-condition sockint::EADDRINUSE address-in-use-error)
(define-socket-condition sockint::EAGAIN interrupted-error)
(define-socket-condition sockint::EBADF bad-file-descriptor-error)
(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
(define-socket-condition sockint::EINTR interrupted-error)
(define-socket-condition sockint::EINVAL invalid-argument-error)
(define-socket-condition sockint::ENOBUFS no-buffers-error)
(define-socket-condition sockint::ENOMEM out-of-memory-error)
(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
(define-socket-condition sockint::EPERM operation-not-permitted-error)
(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
(defun condition-for-errno (err)
(or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
#+cmu
(defun socket-error (where)
;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
;; to update the value that unix-errno looks at. On other CMUCL
;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
(when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
(let ((condition (condition-for-errno sb-unix:unix-errno)))
(error condition :errno sb-unix:unix-errno :syscall where)))
#+sbcl
(defun socket-error (where)
(let* ((errno (sb-unix::get-errno))
(condition (condition-for-errno errno)))
(error condition :errno errno :syscall where)))