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