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-shutdown (socket &key direction)
 380   (:documentation
 381    "Indicate that no communication in DIRECTION will be performed on SOCKET.
 382
 383 DIRECTION has to be one of :INPUT, :OUTPUT or :IO.
 384
 385 After a shutdown, no input and/or output of the indicated DIRECTION
 386 can be performed on SOCKET."))
 387
 388 (defmethod socket-shutdown ((socket socket) &key direction)
 389   (let* ((fd  (socket-file-descriptor socket))
 390          (how (ecase direction
 391                 (:input sockint::SHUT_RD)
 392                 (:output sockint::SHUT_WR)
 393                 (:io sockint::SHUT_RDWR))))
 394     (when (minusp (sockint::shutdown fd how))
 395       (socket-error "shutdown"))))
 396
 397 (defgeneric socket-make-stream (socket &key input output
 398                                        element-type external-format
 399                                        buffering
 400                                        timeout)
 401   (:documentation "Find or create a STREAM that can be used for IO on
 402 SOCKET \(which must be connected\).  Specify whether the stream is for
 403 INPUT, OUTPUT, or both \(it is an error to specify neither\).  ELEMENT-TYPE
 404 and EXTERNAL-FORMAT are as per OPEN.  TIMEOUT specifies a read timeout
 405 for the stream."))
 406
 407 (defmethod socket-make-stream ((socket socket)
 408                                &key input output
 409                                (element-type 'character)
 410                                (buffering :full)
 411                                (external-format :default)
 412                                timeout
 413                                auto-close
 414                                serve-events)
 415   "Default method for SOCKET objects.
 416
 417 ELEMENT-TYPE defaults to CHARACTER, to construct a bivalent stream,
 418 capable of both binary and character IO use :DEFAULT.
 419
 420 Acceptable values for BUFFERING are :FULL, :LINE and :NONE, default
 421 is :FULL, ie. output is buffered till it is explicitly flushed using
 422 CLOSE or FINISH-OUTPUT. (FORCE-OUTPUT forces some output to be
 423 flushed: to ensure all buffered output is flused use FINISH-OUTPUT.)
 424
 425 Streams have no TIMEOUT by default. If one is provided, it is the
 426 number of seconds the system will at most wait for input to appear on
 427 the socket stream when trying to read from it.
 428
 429 If AUTO-CLOSE is true, the underlying OS socket is automatically
 430 closed after the stream and the socket have been garbage collected.
 431 Default is false.
 432
 433 If SERVE-EVENTS is true, blocking IO on the socket will dispatch to
 434 the recursive event loop. Default is false.
 435
 436 The stream for SOCKET will be cached, and a second invocation of this
 437 method will return the same stream. This may lead to oddities if this
 438 function is invoked with inconsistent arguments \(e.g., one might
 439 request an input stream and get an output stream in response\)."
 440   (let ((stream
 441          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
 442     (unless stream
 443       (setf stream (sb-sys:make-fd-stream
 444                     (socket-file-descriptor socket)
 445                     :name (format nil "socket~@[ ~A~]~@[, peer: ~A~]"
 446                                   (socket-namestring socket)
 447                                   (socket-peerstring socket))
 448                     :dual-channel-p t
 449                     :input input
 450                     :output output
 451                     :element-type element-type
 452                     :buffering buffering
 453                     :external-format external-format
 454                     :timeout timeout
 455                     :auto-close auto-close
 456                     :serve-events (and serve-events #+win32 nil)))
 457       (setf (slot-value socket 'stream) stream))
 458     (sb-ext:cancel-finalization socket)
 459     stream))
 460
 461 \f
 462
 463 ;;; Error handling
 464
 465 (define-condition socket-error (error)
 466   ((errno :initform nil
 467           :initarg :errno
 468           :reader socket-error-errno)
 469    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
 470    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
 471   (:report (lambda (c s)
 472              (let ((num (socket-error-errno c)))
 473                (format s "Socket error in \"~A\": ~A (~A)"
 474                        (socket-error-syscall c)
 475                        (or (socket-error-symbol c) (socket-error-errno c))
 476                        #+cmu (sb-unix:get-unix-error-msg num)
 477                        #+sbcl
 478                        #+win32 (sb-win32:format-system-message num)
 479                        #-win32 (sb-int:strerror num)))))
 480   (:documentation "Common base class of socket related conditions."))
 481
 482 ;;; watch out for slightly hacky symbol punning: we use both the value
 483 ;;; and the symbol-name of sockint::efoo
 484
 485 (defmacro define-socket-condition (symbol name)
 486   `(progn
 487      (define-condition ,name (socket-error)
 488        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
 489      (export ',name)
 490      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
 491
 492 (defparameter *conditions-for-errno* nil)
 493 ;;; this needs the rest of the list adding to it, really.  They also
 494 ;;; need symbols to be added to constants.ccon
 495 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
 496 ;;; the same place
 497 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
 498 (define-socket-condition sockint::EAGAIN interrupted-error)
 499 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
 500 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
 501 (define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
 502 (define-socket-condition sockint::EINTR interrupted-error)
 503 (define-socket-condition sockint::EINVAL invalid-argument-error)
 504 (define-socket-condition sockint::ENOBUFS no-buffers-error)
 505 (define-socket-condition sockint::ENOMEM out-of-memory-error)
 506 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
 507 (define-socket-condition sockint::EPERM operation-not-permitted-error)
 508 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
 509 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
 510 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
 511 (define-socket-condition sockint::ENOTCONN not-connected-error)
 512
 513 (defun condition-for-errno (err)
 514   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 515
 516 #+cmu
 517 (defun socket-error (where)
 518   ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
 519   ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
 520   ;; to update the value that unix-errno looks at.  On other CMUCL
 521   ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
 522   (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
 523   (let ((condition (condition-for-errno sb-unix:unix-errno)))
 524     (error condition :errno sb-unix:unix-errno  :syscall where)))
 525
 526 #+sbcl
 527 (defun socket-error (where)
 528   ;; FIXME: Our Texinfo documentation extracter need at least his to spit
 529   ;; out the signature. Real documentation would be better...
 530   ""
 531   (let* ((errno (socket-errno))
 532          (condition (condition-for-errno errno)))
 533     (error condition :errno errno  :syscall where)))
 534
 535
 536 (defgeneric bits-of-sockaddr (socket sockaddr)
 537   (:documentation "Return protocol-dependent bits of parameter
 538 SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
 539
 540 (defgeneric size-of-sockaddr (socket)
 541   (:documentation "Return the size of a sockaddr object for SOCKET."))