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