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

Download this file

sockets.lisp    542 lines (473 with data), 23.8 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
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
(in-package "SB-BSD-SOCKETS")
;;;; Methods, classes, functions for sockets. Protocol-specific stuff
;;;; is deferred to inet.lisp, unix.lisp, etc
(eval-when (:load-toplevel :compile-toplevel :execute)
;;; Winsock is different w.r.t errno
(defun socket-errno ()
"Get socket error code, usually from errno, but see #+win32."
#+win32 (sockint::wsa-get-last-error)
#-win32 (sb-unix::get-errno))
(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
:documentation "Protocol used by the socket. If a
keyword, the symbol-name of the keyword will be passed to
GET-PROTOCOL-BY-NAME downcased, and the returned value used as
protocol. Other values are used as-is.")
(type :initarg :type
:reader socket-type
:documentation "Type of the socket: :STREAM or :DATAGRAM.")
#+win32
(non-blocking-p :type (member t nil) :initform nil)
(stream))
(:documentation "Common base class of all sockets, not meant to be
directly instantiated.")))
(defmethod print-object ((object socket) stream)
(print-unreadable-object (object stream :type t :identity t)
(format stream "~@[~A, ~]~@[peer: ~A, ~]fd: ~A"
(socket-namestring object)
(socket-peerstring object)
(slot-value object 'file-descriptor))))
(defgeneric socket-namestring (socket))
(defmethod socket-namestring (socket)
nil)
(defgeneric socket-peerstring (socket))
(defmethod socket-peerstring (socket)
nil)
(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))
:dont-save t)))
(defgeneric make-sockaddr-for (socket &optional sockaddr &rest address)
(:documentation "Return a Socket Address object suitable for use with SOCKET.
When SOCKADDR is passed, it is used instead of a new object."))
(defgeneric free-sockaddr-for (socket sockaddr)
(:documentation "Deallocate a Socket Address object that was
created for SOCKET."))
(defmacro with-sockaddr-for ((socket sockaddr &optional sockaddr-args) &body body)
`(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args)))
(unwind-protect (progn ,@body)
(free-sockaddr-for ,socket ,sockaddr))))
;; 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)
(:documentation "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)"))
(defmethod socket-bind ((socket socket)
&rest address)
(with-sockaddr-for (socket sockaddr address)
(if (= (sockint::bind (socket-file-descriptor socket)
sockaddr
(size-of-sockaddr socket))
-1)
(socket-error "bind"))))
(defgeneric socket-accept (socket)
(:documentation "Perform the accept(2) call, returning a
newly-created connected socket and the peer address as multiple
values"))
(defmethod socket-accept ((socket socket))
(with-sockaddr-for (socket sockaddr)
(let ((fd (sockint::accept (socket-file-descriptor socket)
sockaddr
(size-of-sockaddr socket))))
(cond
((and (= fd -1)
(member (socket-errno)
(list sockint::EAGAIN sockint::EINTR)))
nil)
((= fd -1) (socket-error "accept"))
(t (apply #'values
(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))
:dont-save t))
(multiple-value-list (bits-of-sockaddr socket sockaddr))))))))
(defgeneric socket-connect (socket &rest address)
(:documentation "Perform the connect(2) call to connect SOCKET to a
remote PEER. No useful return value."))
(defmethod socket-connect ((socket socket) &rest peer)
(with-sockaddr-for (socket sockaddr peer)
(if (= (sockint::connect (socket-file-descriptor socket)
sockaddr
(size-of-sockaddr socket))
-1)
(socket-error "connect"))))
(defgeneric socket-peername (socket)
(:documentation "Return the socket's peer; depending on the address
family this may return multiple values"))
(defmethod socket-peername ((socket socket))
(with-sockaddr-for (socket sockaddr)
(when (= (sockint::getpeername (socket-file-descriptor socket)
sockaddr
(size-of-sockaddr socket))
-1)
(socket-error "getpeername"))
(bits-of-sockaddr socket sockaddr)))
(defgeneric socket-name (socket)
(:documentation "Return the address (as vector of bytes) and port
that the socket is bound to, as multiple values."))
(defmethod socket-name ((socket socket))
(with-sockaddr-for (socket sockaddr)
(when (= (sockint::getsockname (socket-file-descriptor socket)
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
(defgeneric socket-receive (socket buffer length
&key
oob peek waitall dontwait element-type)
(:documentation
"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."))
(defmethod socket-receive ((socket socket) buffer length
&key
oob peek waitall dontwait
(element-type 'character))
(with-sockaddr-for (socket sockaddr)
(let ((flags
(logior (if oob sockint::MSG-OOB 0)
(if peek sockint::MSG-PEEK 0)
(if waitall sockint::MSG-WAITALL 0)
(if dontwait sockint::MSG-DONTWAIT 0)
#+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
(if (eql (socket-type socket) :datagram)
sockint::msg-TRUNC 0))))
(unless (or buffer length)
(error "Must supply at least one of BUFFER or LENGTH"))
(unless length
(setf length (length buffer)))
(when buffer (setf element-type (array-element-type buffer)))
(unless (or (subtypep element-type 'character)
(subtypep element-type 'integer))
(error "Buffer element-type must be either a character or an integer subtype."))
(unless buffer
(setf buffer (make-array length :element-type element-type)))
;; really big FIXME: This whole copy-buffer thing is broken.
;; doesn't support characters more than 8 bits wide, or integer
;; types that aren't (unsigned-byte 8).
(let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
(unwind-protect
(sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket)))
(let ((len
(sockint::recvfrom (socket-file-descriptor socket)
copy-buffer
length
flags
sockaddr
(sb-alien:addr sa-len))))
(cond
((and (= len -1)
(member (socket-errno)
(list sockint::EAGAIN sockint::EINTR)))
nil)
((= len -1) (socket-error "recvfrom"))
(t (loop for i from 0 below (min len length)
do (setf (elt buffer i)
(cond
((or (eql element-type 'character) (eql element-type 'base-char))
(code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
(t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
(apply #'values buffer len (multiple-value-list
(bits-of-sockaddr socket sockaddr)))))))
(sb-alien:free-alien copy-buffer))))))
(defmacro with-vector-sap ((name vector) &body body)
`(sb-sys:with-pinned-objects (,vector)
(let ((,name (sb-sys:vector-sap ,vector)))
,@body)))
(defgeneric socket-send (socket buffer length
&key
address
external-format
oob eor dontroute dontwait nosignal
#+linux confirm #+linux more)
(:documentation
"Send LENGTH octets from BUFFER into SOCKET, using sendto(2). If BUFFER
is a string, it will converted to octets according to EXTERNAL-FORMAT. If
LENGTH is NIL, the length of the octet buffer is used. The format of ADDRESS
depends on the socket type (for example for INET domain sockets it would
be a list of an IP address and a port). If no socket address is provided,
send(2) will be called instead. Returns the number of octets written."))
(defmethod socket-send ((socket socket) buffer length
&key
address
(external-format :default)
oob eor dontroute dontwait nosignal
#+linux confirm #+linux more)
(let* ((flags
(logior (if oob sockint::MSG-OOB 0)
(if eor sockint::MSG-EOR 0)
(if dontroute sockint::MSG-DONTROUTE 0)
(if dontwait sockint::MSG-DONTWAIT 0)
#-darwin (if nosignal sockint::MSG-NOSIGNAL 0)
#+linux (if confirm sockint::MSG-CONFIRM 0)
#+linux (if more sockint::MSG-MORE 0)))
(buffer (etypecase buffer
(string
(sb-ext:string-to-octets buffer
:external-format external-format
:null-terminate nil))
((simple-array (unsigned-byte 8))
buffer)
((array (unsigned-byte 8))
(make-array (length buffer)
:element-type '(unsigned-byte 8)
:initial-contents buffer))))
(len (with-vector-sap (buffer-sap buffer)
(unless length
(setf length (length buffer)))
(if address
(with-sockaddr-for (socket sockaddr address)
(sb-alien:with-alien ((sa-len sockint::socklen-t
(size-of-sockaddr socket)))
(sockint::sendto (socket-file-descriptor socket)
buffer-sap
length
flags
sockaddr
sa-len)))
(sockint::send (socket-file-descriptor socket)
buffer-sap
length
flags)))))
(cond
((and (= len -1)
(member (socket-errno)
(list sockint::EAGAIN sockint::EINTR)))
nil)
((= len -1)
(socket-error "sendto"))
(t len))))
(defgeneric socket-listen (socket backlog)
(:documentation "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)"))
(defmethod socket-listen ((socket socket) backlog)
(let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
(if (= r -1)
(socket-error "listen"))))
(defgeneric socket-open-p (socket)
(:documentation "Return true if SOCKET is open; otherwise, return false.")
(:method ((socket t)) (error 'type-error
:datum socket :expected-type 'socket)))
(defmethod socket-open-p ((socket socket))
(if (slot-boundp socket 'stream)
(open-stream-p (slot-value socket 'stream))
(/= -1 (socket-file-descriptor socket))))
(defgeneric socket-close (socket &key abort)
(:documentation
"Close SOCKET, unless it was already closed.
If SOCKET-MAKE-STREAM has been called, calls CLOSE using ABORT on that stream.
Otherwise closes the socket file descriptor using close(2)."))
(defmethod socket-close ((socket socket) &key abort)
;; 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.
;; note that if you have a socket _and_ a stream on the same fd,
;; the socket will avoid doing anything to close the fd in case
;; the stream has done it already - if so, it may have been
;; reassigned to some other file, and closing it would be bad
(let ((fd (socket-file-descriptor socket)))
(flet ((drop-it (&optional streamp)
(setf (slot-value socket 'file-descriptor) -1)
(if streamp
(slot-makunbound socket 'stream)
(sb-ext:cancel-finalization socket))
t))
(cond ((eql fd -1)
;; already closed
nil)
((slot-boundp socket 'stream)
(close (slot-value socket 'stream) :abort abort)
;; Don't do this if there was an error from CLOSE -- the stream is
;; still live.
(drop-it t))
(t
(handler-case
(when (minusp (sockint::close fd))
(socket-error "close"))
(bad-file-descriptor-error ()
(drop-it))
(:no-error (r)
(declare (ignore r))
(drop-it))))))))
(defgeneric socket-shutdown (socket &key direction)
(:documentation
"Indicate that no communication in DIRECTION will be performed on SOCKET.
DIRECTION has to be one of :INPUT, :OUTPUT or :IO.
After a shutdown, no input and/or output of the indicated DIRECTION
can be performed on SOCKET."))
(defmethod socket-shutdown ((socket socket) &key direction)
(let* ((fd (socket-file-descriptor socket))
(how (ecase direction
(:input sockint::SHUT_RD)
(:output sockint::SHUT_WR)
(:io sockint::SHUT_RDWR))))
(when (minusp (sockint::shutdown fd how))
(socket-error "shutdown"))))
(defgeneric socket-make-stream (socket &key input output
element-type external-format
buffering
timeout)
(:documentation "Find or create a STREAM that can be used for IO on
SOCKET \(which must be connected\). Specify whether the stream is for
INPUT, OUTPUT, or both \(it is an error to specify neither\). ELEMENT-TYPE
and EXTERNAL-FORMAT are as per OPEN. TIMEOUT specifies a read timeout
for the stream."))
(defmethod socket-make-stream ((socket socket)
&key input output
(element-type 'character)
(buffering :full)
(external-format :default)
timeout
auto-close
serve-events)
"Default method for SOCKET objects.
ELEMENT-TYPE defaults to CHARACTER, to construct a bivalent stream,
capable of both binary and character IO use :DEFAULT.
Acceptable values for BUFFERING are :FULL, :LINE and :NONE, default
is :FULL, ie. output is buffered till it is explicitly flushed using
CLOSE or FINISH-OUTPUT. (FORCE-OUTPUT forces some output to be
flushed: to ensure all buffered output is flused use FINISH-OUTPUT.)
Streams have no TIMEOUT by default. If one is provided, it is the
number of seconds the system will at most wait for input to appear on
the socket stream when trying to read from it.
If AUTO-CLOSE is true, the underlying OS socket is automatically
closed after the stream and the socket have been garbage collected.
Default is false.
If SERVE-EVENTS is true, blocking IO on the socket will dispatch to
the recursive event loop. Default is false.
The stream for SOCKET will be cached, and a second invocation of this
method will return the same stream. This may lead to oddities if this
function is invoked with inconsistent arguments \(e.g., one might
request an input stream and get an output stream in response\)."
(let ((stream
(and (slot-boundp socket 'stream) (slot-value socket 'stream))))
(unless stream
(setf stream (sb-sys:make-fd-stream
(socket-file-descriptor socket)
:name (format nil "socket~@[ ~A~]~@[, peer: ~A~]"
(socket-namestring socket)
(socket-peerstring socket))
:dual-channel-p t
:input input
:output output
:element-type element-type
:buffering buffering
:external-format external-format
:timeout timeout
:auto-close auto-close
:serve-events (and serve-events #+win32 nil)))
(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
#+win32 (sb-win32:format-system-message num)
#-win32 (sb-int:strerror num)))))
(:documentation "Common base class of socket related conditions."))
;;; 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))))
(export ',name)
(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 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::ETIMEDOUT operation-timeout-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)
(define-socket-condition sockint::ENOTCONN not-connected-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)
;; FIXME: Our Texinfo documentation extracter need at least his to spit
;; out the signature. Real documentation would be better...
""
(let* ((errno (socket-errno))
(condition (condition-for-errno errno)))
(error condition :errno errno :syscall where)))
(defgeneric bits-of-sockaddr (socket sockaddr)
(:documentation "Return protocol-dependent bits of parameter
SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
(defgeneric size-of-sockaddr (socket)
(:documentation "Return the size of a sockaddr object for SOCKET."))