Stop emitting references to inexistant #n= forms in the pretty printer
[sbcl.git] / contrib / sb-bsd-sockets / sockets.lisp
1 (in-package "SB-BSD-SOCKETS")
2
3 ;;;; Methods, classes, functions for sockets.  Protocol-specific stuff
4 ;;;; is deferred to inet.lisp, unix.lisp, etc
5
6 (eval-when (:load-toplevel :compile-toplevel :execute)
7
8
9 ;;; Winsock is different w.r.t errno
10 (defun socket-errno ()
11   "Get socket error code, usually from errno, but see #+win32."
12   #+win32 (sockint::wsa-get-last-error)
13   #-win32 (sb-unix::get-errno))
14
15 (defclass socket ()
16   ((file-descriptor :initarg :descriptor
17                     :reader socket-file-descriptor)
18    (family :initform (error "No socket family")
19            :reader socket-family)
20    (protocol :initarg :protocol
21              :reader socket-protocol
22              :documentation "Protocol used by the socket. If a
23 keyword, the symbol-name of the keyword will be passed to
24 GET-PROTOCOL-BY-NAME downcased, and the returned value used as
25 protocol. Other values are used as-is.")
26    (type  :initarg :type
27           :reader socket-type
28           :documentation "Type of the socket: :STREAM or :DATAGRAM.")
29    #+win32
30    (non-blocking-p :type (member t nil) :initform nil)
31    (stream))
32   (:documentation "Common base class of all sockets, not meant to be
33 directly instantiated.")))
34
35 (defmethod print-object ((object socket) stream)
36   (print-unreadable-object (object stream :type t :identity t)
37     (format stream "~@[~A, ~]~@[peer: ~A, ~]fd: ~A"
38             (socket-namestring object)
39             (socket-peerstring object)
40             (slot-value object 'file-descriptor))))
41
42 (defgeneric socket-namestring (socket))
43
44 (defmethod socket-namestring (socket)
45   nil)
46
47 (defgeneric socket-peerstring (socket))
48
49 (defmethod socket-peerstring (socket)
50   nil)
51
52 (defmethod shared-initialize :after ((socket socket) slot-names
53                                      &key protocol type
54                                      &allow-other-keys)
55   (let* ((proto-num
56           (cond ((and protocol (keywordp protocol))
57                  (get-protocol-by-name (string-downcase (symbol-name protocol))))
58                 (protocol protocol)
59                 (t 0)))
60          (fd (or (and (slot-boundp socket 'file-descriptor)
61                       (socket-file-descriptor socket))
62                  (sockint::socket (socket-family socket)
63                                   (ecase type
64                                     ((:datagram) sockint::sock-dgram)
65                                     ((:stream) sockint::sock-stream))
66                                   proto-num))))
67       (if (= fd -1) (socket-error "socket"))
68       (setf (slot-value socket 'file-descriptor) fd
69             (slot-value socket 'protocol) proto-num
70             (slot-value socket 'type) type)
71       (sb-ext:finalize socket (lambda () (sockint::close fd))
72                        :dont-save t)))
73
74 \f
75
76 (defgeneric make-sockaddr-for (socket &optional sockaddr &rest address)
77   (:documentation "Return a Socket Address object suitable for use with SOCKET.
78 When SOCKADDR is passed, it is used instead of a new object."))
79
80 (defgeneric free-sockaddr-for (socket sockaddr)
81   (:documentation "Deallocate a Socket Address object that was
82 created for SOCKET."))
83
84 (defmacro with-sockaddr-for ((socket sockaddr &optional sockaddr-args) &body body)
85   `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args)))
86      (unwind-protect (progn ,@body)
87        (free-sockaddr-for ,socket ,sockaddr))))
88
89 ;; we deliberately redesign the "bind" interface: instead of passing a
90 ;; sockaddr_something as second arg, we pass the elements of one as
91 ;; multiple arguments.
92
93 (defgeneric socket-bind (socket &rest address)
94   (:documentation "Bind SOCKET to ADDRESS, which may vary according to
95 socket family.  For the INET family, pass ADDRESS and PORT as two
96 arguments; for FILE address family sockets, pass the filename string.
97 See also bind(2)"))
98
99 (defmethod socket-bind ((socket socket)
100                         &rest address)
101   (with-sockaddr-for (socket sockaddr address)
102     (if (= (sockint::bind (socket-file-descriptor socket)
103                           sockaddr
104                           (size-of-sockaddr socket))
105            -1)
106         (socket-error "bind"))))
107
108 \f
109 (defgeneric socket-accept (socket)
110   (:documentation "Perform the accept(2) call, returning a
111 newly-created connected socket and the peer address as multiple
112 values"))
113
114 (defmethod socket-accept ((socket socket))
115   (with-sockaddr-for (socket sockaddr)
116     (let ((fd (sockint::accept (socket-file-descriptor socket)
117                                sockaddr
118                                (size-of-sockaddr socket))))
119       (cond
120         ((and (= fd -1)
121               (member (socket-errno)
122                       (list sockint::EAGAIN sockint::EINTR)))
123          nil)
124         ((= fd -1) (socket-error "accept"))
125         (t (apply #'values
126                   (let ((s (make-instance (class-of socket)
127                               :type (socket-type socket)
128                               :protocol (socket-protocol socket)
129                               :descriptor fd)))
130                     (sb-ext:finalize s (lambda () (sockint::close fd))
131                                      :dont-save t))
132                   (multiple-value-list (bits-of-sockaddr socket sockaddr))))))))
133
134 (defgeneric socket-connect (socket &rest address)
135   (:documentation "Perform the connect(2) call to connect SOCKET to a
136   remote PEER.  No useful return value."))
137
138 (defmethod socket-connect ((socket socket) &rest peer)
139   (with-sockaddr-for (socket sockaddr peer)
140     (if (= (sockint::connect (socket-file-descriptor socket)
141                              sockaddr
142                              (size-of-sockaddr socket))
143            -1)
144         (socket-error "connect"))))
145
146 (defgeneric socket-peername (socket)
147   (:documentation "Return the socket's peer; depending on the address
148   family this may return multiple values"))
149
150 (defmethod socket-peername ((socket socket))
151   (with-sockaddr-for (socket sockaddr)
152     (when (= (sockint::getpeername (socket-file-descriptor socket)
153                                     sockaddr
154                                     (size-of-sockaddr socket))
155              -1)
156       (socket-error "getpeername"))
157     (bits-of-sockaddr socket sockaddr)))
158
159 (defgeneric socket-name (socket)
160   (:documentation "Return the address (as vector of bytes) and port
161   that the socket is bound to, as multiple values."))
162
163 (defmethod socket-name ((socket socket))
164   (with-sockaddr-for (socket sockaddr)
165     (when (= (sockint::getsockname (socket-file-descriptor socket)
166                                    sockaddr
167                                    (size-of-sockaddr socket))
168              -1)
169       (socket-error "getsockname"))
170     (bits-of-sockaddr socket sockaddr)))
171
172
173 ;;; There are a whole bunch of interesting things you can do with a
174 ;;; socket that don't really map onto "do stream io", especially in
175 ;;; CL which has no portable concept of a "short read".  socket-receive
176 ;;; allows us to read from an unconnected socket into a buffer, and
177 ;;; to learn who the sender of the packet was
178
179 (defgeneric socket-receive (socket buffer length
180                             &key
181                             oob peek waitall dontwait element-type)
182   (:documentation
183    "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed
184 buffer if NIL), using recvfrom(2). If LENGTH is NIL, the length of
185 BUFFER is used, so at least one of these two arguments must be
186 non-NIL. If BUFFER is supplied, it had better be of an element type
187 one octet wide. Returns the buffer, its length, and the address of the
188 peer that sent it, as multiple values. On datagram sockets, sets
189 MSG_TRUNC so that the actual packet length is returned even if the
190 buffer was too small."))
191
192 (defmethod socket-receive ((socket socket) buffer length
193                            &key
194                            oob peek waitall dontwait
195                            (element-type 'character))
196   (with-sockaddr-for (socket sockaddr)
197     (let ((flags
198            (logior (if oob sockint::MSG-OOB 0)
199                    (if peek sockint::MSG-PEEK 0)
200                    (if waitall sockint::MSG-WAITALL 0)
201                    (if dontwait sockint::MSG-DONTWAIT 0)
202                    #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
203                    (if (eql (socket-type socket) :datagram)
204                        sockint::msg-TRUNC 0))))
205       (unless (or buffer length)
206         (error "Must supply at least one of BUFFER or LENGTH"))
207       (unless length
208         (setf length (length buffer)))
209       (when buffer (setf element-type (array-element-type buffer)))
210       (unless (or (subtypep element-type 'character)
211                   (subtypep element-type 'integer))
212         (error "Buffer element-type must be either a character or an integer subtype."))
213       (unless buffer
214         (setf buffer (make-array length :element-type element-type)))
215       ;; really big FIXME: This whole copy-buffer thing is broken.
216       ;; doesn't support characters more than 8 bits wide, or integer
217       ;; types that aren't (unsigned-byte 8).
218       (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
219         (unwind-protect
220             (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket)))
221               (let ((len
222                      (sockint::recvfrom (socket-file-descriptor socket)
223                                         copy-buffer
224                                         length
225                                         flags
226                                         sockaddr
227                                         (sb-alien:addr sa-len))))
228                 (cond
229                   ((and (= len -1)
230                         (member (socket-errno)
231                                 (list sockint::EAGAIN sockint::EINTR)))
232                    nil)
233                   ((= len -1) (socket-error "recvfrom"))
234                   (t (loop for i from 0 below (min len length)
235                            do (setf (elt buffer i)
236                                     (cond
237                                       ((or (eql element-type 'character) (eql element-type 'base-char))
238                                        (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
239                                       (t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
240                      (apply #'values buffer len (multiple-value-list
241                                                  (bits-of-sockaddr socket sockaddr)))))))
242           (sb-alien:free-alien copy-buffer))))))
243
244 (defmacro with-vector-sap ((name vector) &body body)
245   `(sb-sys:with-pinned-objects (,vector)
246      (let ((,name (sb-sys:vector-sap ,vector)))
247        ,@body)))
248
249 (defgeneric socket-send (socket buffer length
250                                 &key
251                                 address
252                                 external-format
253                                 oob eor dontroute dontwait nosignal
254                                 #+linux confirm #+linux more)
255   (:documentation
256    "Send LENGTH octets from BUFFER into SOCKET, using sendto(2). If BUFFER
257 is a string, it will converted to octets according to EXTERNAL-FORMAT. If
258 LENGTH is NIL, the length of the octet buffer is used. The format of ADDRESS
259 depends on the socket type (for example for INET domain sockets it would
260 be a list of an IP address and a port). If no socket address is provided,
261 send(2) will be called instead. Returns the number of octets written."))
262
263 (defmethod socket-send ((socket socket) buffer length
264                         &key
265                         address
266                         (external-format :default)
267                         oob eor dontroute dontwait nosignal
268                         #+linux confirm #+linux more)
269   (let* ((flags
270           (logior (if oob sockint::MSG-OOB 0)
271                   (if eor sockint::MSG-EOR 0)
272                   (if dontroute sockint::MSG-DONTROUTE 0)
273                   (if dontwait sockint::MSG-DONTWAIT 0)
274                   #-darwin (if nosignal sockint::MSG-NOSIGNAL 0)
275                   #+linux (if confirm sockint::MSG-CONFIRM 0)
276                   #+linux (if more sockint::MSG-MORE 0)))
277          (buffer (etypecase buffer
278                    (string
279                     (sb-ext:string-to-octets buffer
280                                              :external-format external-format
281                                              :null-terminate nil))
282                    ((simple-array (unsigned-byte 8))
283                     buffer)
284                    ((array (unsigned-byte 8))
285                     (make-array (length buffer)
286                                 :element-type '(unsigned-byte 8)
287                                 :initial-contents buffer))))
288          (len (with-vector-sap (buffer-sap buffer)
289                 (unless length
290                   (setf length (length buffer)))
291                 (if address
292                     (with-sockaddr-for (socket sockaddr address)
293                       (sb-alien:with-alien ((sa-len sockint::socklen-t
294                                                     (size-of-sockaddr socket)))
295                         (sockint::sendto (socket-file-descriptor socket)
296                                          buffer-sap
297                                          length
298                                          flags
299                                          sockaddr
300                                          sa-len)))
301                     (sockint::send (socket-file-descriptor socket)
302                                    buffer-sap
303                                    length
304                                    flags)))))
305     (cond
306       ((and (= len -1)
307             (member (socket-errno)
308                     (list sockint::EAGAIN sockint::EINTR)))
309        nil)
310       ((= len -1)
311        (socket-error "sendto"))
312       (t len))))
313
314 (defgeneric socket-listen (socket backlog)
315   (:documentation "Mark SOCKET as willing to accept incoming connections.  BACKLOG
316 defines the maximum length that the queue of pending connections may
317 grow to before new connection attempts are refused.  See also listen(2)"))
318
319 (defmethod socket-listen ((socket socket) backlog)
320   (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
321     (if (= r -1)
322         (socket-error "listen"))))
323
324 (defgeneric socket-open-p (socket)
325   (:documentation "Return true if SOCKET is open; otherwise, return false.")
326   (:method ((socket t)) (error 'type-error
327                                :datum socket :expected-type 'socket)))
328
329 (defmethod socket-open-p ((socket socket))
330   (if (slot-boundp socket 'stream)
331       (open-stream-p (slot-value socket 'stream))
332       (/= -1 (socket-file-descriptor socket))))
333
334 (defgeneric socket-close (socket &key abort)
335   (:documentation
336    "Close SOCKET, unless it was already closed.
337
338 If SOCKET-MAKE-STREAM has been called, calls CLOSE using ABORT on that stream.
339 Otherwise closes the socket file descriptor using close(2)."))
340
341 (defmethod socket-close ((socket socket) &key abort)
342   ;; the close(2) manual page has all kinds of warning about not
343   ;; checking the return value of close, on the grounds that an
344   ;; earlier write(2) might have returned successfully w/o actually
345   ;; writing the stuff to disk.  It then goes on to define the only
346   ;; possible error return as EBADF (fd isn't a valid open file
347   ;; descriptor).  Presumably this is an oversight and we could also
348   ;; get anything that write(2) would have given us.
349
350   ;; note that if you have a socket _and_ a stream on the same fd,
351   ;; the socket will avoid doing anything to close the fd in case
352   ;; the stream has done it already - if so, it may have been
353   ;; reassigned to some other file, and closing it would be bad
354   (let ((fd (socket-file-descriptor socket)))
355     (flet ((drop-it (&optional streamp)
356              (setf (slot-value socket 'file-descriptor) -1)
357              (if streamp
358                  (slot-makunbound socket 'stream)
359                  (sb-ext:cancel-finalization socket))
360              t))
361       (cond ((eql fd -1)
362              ;; already closed
363              nil)
364            ((slot-boundp socket 'stream)
365             (close (slot-value socket 'stream) :abort abort)
366             ;; Don't do this if there was an error from CLOSE -- the stream is
367             ;; still live.
368             (drop-it t))
369            (t
370             (handler-case
371                 (when (minusp (sockint::close fd))
372                   (socket-error "close"))
373               (bad-file-descriptor-error ()
374                 (drop-it))
375               (:no-error (r)
376                 (declare (ignore r))
377                 (drop-it))))))))
378
379 (defgeneric socket-make-stream (socket &key input output
380                                        element-type external-format
381                                        buffering
382                                        timeout)
383   (:documentation "Find or create a STREAM that can be used for IO on
384 SOCKET \(which must be connected\).  Specify whether the stream is for
385 INPUT, OUTPUT, or both \(it is an error to specify neither\).  ELEMENT-TYPE
386 and EXTERNAL-FORMAT are as per OPEN.  TIMEOUT specifies a read timeout
387 for the stream."))
388
389 (defmethod socket-make-stream ((socket socket)
390                                &key input output
391                                (element-type 'character)
392                                (buffering :full)
393                                (external-format :default)
394                                timeout
395                                auto-close
396                                serve-events)
397   "Default method for SOCKET objects.
398
399 ELEMENT-TYPE defaults to CHARACTER, to construct a bivalent stream,
400 capable of both binary and character IO use :DEFAULT.
401
402 Acceptable values for BUFFERING are :FULL, :LINE and :NONE, default
403 is :FULL, ie. output is buffered till it is explicitly flushed using
404 CLOSE or FINISH-OUTPUT. (FORCE-OUTPUT forces some output to be
405 flushed: to ensure all buffered output is flused use FINISH-OUTPUT.)
406
407 Streams have no TIMEOUT by default. If one is provided, it is the
408 number of seconds the system will at most wait for input to appear on
409 the socket stream when trying to read from it.
410
411 If AUTO-CLOSE is true, the underlying OS socket is automatically
412 closed after the stream and the socket have been garbage collected.
413 Default is false.
414
415 If SERVE-EVENTS is true, blocking IO on the socket will dispatch to
416 the recursive event loop. Default is false.
417
418 The stream for SOCKET will be cached, and a second invocation of this
419 method will return the same stream. This may lead to oddities if this
420 function is invoked with inconsistent arguments \(e.g., one might
421 request an input stream and get an output stream in response\)."
422   (let ((stream
423          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
424     (unless stream
425       (setf stream (sb-sys:make-fd-stream
426                     (socket-file-descriptor socket)
427                     :name (format nil "socket~@[ ~A~]~@[, peer: ~A~]"
428                                   (socket-namestring socket)
429                                   (socket-peerstring socket))
430                     :dual-channel-p t
431                     :input input
432                     :output output
433                     :element-type element-type
434                     :buffering buffering
435                     :external-format external-format
436                     :timeout timeout
437                     :auto-close auto-close
438                     :serve-events (and serve-events #+win32 nil)))
439       (setf (slot-value socket 'stream) stream))
440     (sb-ext:cancel-finalization socket)
441     stream))
442
443 \f
444
445 ;;; Error handling
446
447 (define-condition socket-error (error)
448   ((errno :initform nil
449           :initarg :errno
450           :reader socket-error-errno)
451    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
452    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
453   (:report (lambda (c s)
454              (let ((num (socket-error-errno c)))
455                (format s "Socket error in \"~A\": ~A (~A)"
456                        (socket-error-syscall c)
457                        (or (socket-error-symbol c) (socket-error-errno c))
458                        #+cmu (sb-unix:get-unix-error-msg num)
459                        #+sbcl
460                        #+win32 (sb-win32::get-last-error-message num)
461                        #-win32 (sb-int:strerror num)))))
462   (:documentation "Common base class of socket related conditions."))
463
464 ;;; watch out for slightly hacky symbol punning: we use both the value
465 ;;; and the symbol-name of sockint::efoo
466
467 (defmacro define-socket-condition (symbol name)
468   `(progn
469      (define-condition ,name (socket-error)
470        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
471      (export ',name)
472      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
473
474 (defparameter *conditions-for-errno* nil)
475 ;;; this needs the rest of the list adding to it, really.  They also
476 ;;; need symbols to be added to constants.ccon
477 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
478 ;;; the same place
479 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
480 (define-socket-condition sockint::EAGAIN interrupted-error)
481 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
482 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
483 (define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
484 (define-socket-condition sockint::EINTR interrupted-error)
485 (define-socket-condition sockint::EINVAL invalid-argument-error)
486 (define-socket-condition sockint::ENOBUFS no-buffers-error)
487 (define-socket-condition sockint::ENOMEM out-of-memory-error)
488 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
489 (define-socket-condition sockint::EPERM operation-not-permitted-error)
490 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
491 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
492 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
493 (define-socket-condition sockint::ENOTCONN not-connected-error)
494
495 (defun condition-for-errno (err)
496   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
497
498 #+cmu
499 (defun socket-error (where)
500   ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
501   ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
502   ;; to update the value that unix-errno looks at.  On other CMUCL
503   ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
504   (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
505   (let ((condition (condition-for-errno sb-unix:unix-errno)))
506     (error condition :errno sb-unix:unix-errno  :syscall where)))
507
508 #+sbcl
509 (defun socket-error (where)
510   ;; FIXME: Our Texinfo documentation extracter need at least his to spit
511   ;; out the signature. Real documentation would be better...
512   ""
513   (let* ((errno (socket-errno))
514          (condition (condition-for-errno errno)))
515     (error condition :errno errno  :syscall where)))
516
517
518 (defgeneric bits-of-sockaddr (socket sockaddr)
519   (:documentation "Return protocol-dependent bits of parameter
520 SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
521
522 (defgeneric size-of-sockaddr (socket)
523   (:documentation "Return the size of a sockaddr object for SOCKET."))