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