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