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