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 ;;; Winsock is different w.r.t errno
   9 (defun socket-errno ()
  10   "Get socket error code, usually from errno, but see #+win32."
  11   #+win32 (sockint::wsa-get-last-error)
  12   #-win32 (sb-unix::get-errno))
  13
  14 (defclass socket ()
  15   ((file-descriptor :initarg :descriptor
  16                     :reader socket-file-descriptor)
  17    (family :initform (error "No socket family") ; subclasses supply initforms
  18            :reader socket-family)
  19    (protocol :initarg :protocol
  20              :reader socket-protocol
  21              :documentation "Protocol used by the socket. If a
  22 keyword, the symbol-name of the keyword will be passed to
  23 GET-PROTOCOL-BY-NAME downcased, and the returned value used as
  24 protocol. Other values are used as-is.")
  25    (type  :initarg :type
  26           :reader socket-type
  27           :documentation "Type of the socket: :STREAM or :DATAGRAM.")
  28    #+win32
  29    (non-blocking-p :type (member t nil) :initform nil)
  30    (stream))
  31   (:default-initargs
  32    :type (sb-int:missing-arg))
  33   (:documentation "Common superclass of all sockets, not meant to be
  34 directly instantiated.")))
  35
  36 (defmethod print-object ((object socket) stream)
  37   (print-unreadable-object (object stream :type t :identity t)
  38     (format stream "~@[~A, ~]~@[peer: ~A, ~]fd: ~A"
  39             (socket-namestring object)
  40             (socket-peerstring object)
  41             (slot-value object 'file-descriptor))))
  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 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     (socket-error-case ("socket" fd)
  59         (progn
  60           (setf (slot-value socket 'file-descriptor) fd
  61                 (slot-value socket 'protocol) proto-num
  62                 (slot-value socket 'type) type)
  63           (sb-ext:finalize socket (lambda () (sockint::close fd))
  64                            :dont-save t)))))
  65
  66 \f
  67
  68 (defun call-with-socket-addr (socket sockaddr-args thunk)
  69   (multiple-value-bind (sockaddr size)
  70       (apply #'make-sockaddr-for socket nil sockaddr-args)
  71     (unless size
  72       (setf size (size-of-sockaddr socket)))
  73     (unwind-protect (funcall thunk sockaddr size)
  74       (free-sockaddr-for socket sockaddr))))
  75
  76 (defmacro with-socket-addr ((sockaddr-var size-of-sockaddr-var
  77                             &optional sockaddr-args)
  78                             socket &body body)
  79   `(sb-int:dx-flet ((with-socket-addr-thunk (,sockaddr-var ,size-of-sockaddr-var)
  80                       ,@body))
  81      (call-with-socket-addr ,socket ,sockaddr-args #'with-socket-addr-thunk)))
  82
  83 (defmacro with-socket-fd-and-addr ((fd-var sockaddr-var size-of-sockaddr-var
  84                                    &optional sockaddr-args)
  85                                    socket &body body)
  86   (sb-int:once-only ((socket socket))
  87     `(let ((,fd-var (socket-file-descriptor ,socket)))
  88        (with-socket-addr (,sockaddr-var ,size-of-sockaddr-var ,sockaddr-args)
  89            ,socket
  90          ,@body))))
  91
  92
  93 ;; we deliberately redesign the "bind" interface: instead of passing a
  94 ;; sockaddr_something as second arg, we pass the elements of one as
  95 ;; multiple arguments.
  96 (defmethod socket-bind ((socket socket) &rest address)
  97   (with-socket-fd-and-addr (fd sockaddr size address) socket
  98     (socket-error-case ("bind" (sockint::bind fd sockaddr size)))))
  99
 100 \f
 101
 102 (defmethod socket-accept ((socket socket))
 103   (with-socket-fd-and-addr (fd sockaddr size) socket
 104     (socket-error-case ("accept" (sockint::accept fd sockaddr size) new-fd)
 105         (multiple-value-call #'values
 106           (let ((socket (make-instance (class-of socket)
 107                                        :type (socket-type socket)
 108                                        :protocol (socket-protocol socket)
 109                                        :descriptor new-fd)))
 110             (sb-ext:finalize socket (lambda () (sockint::close new-fd))
 111                              :dont-save t))
 112           (bits-of-sockaddr socket sockaddr))
 113       (:interrupted nil))))
 114
 115 (defmethod socket-connect ((socket socket) &rest peer)
 116   (with-socket-fd-and-addr (fd sockaddr size peer) socket
 117     (socket-error-case ("connect" (sockint::connect fd sockaddr size))
 118         socket)))
 119
 120 (defmethod socket-peername ((socket socket))
 121   (with-socket-fd-and-addr (fd sockaddr size) socket
 122     (socket-error-case ("getpeername" (sockint::getpeername fd sockaddr size))
 123         (bits-of-sockaddr socket sockaddr))))
 124
 125 (defmethod socket-name ((socket socket))
 126   (with-socket-fd-and-addr (fd sockaddr size) socket
 127     (socket-error-case ("getsockname" (sockint::getsockname fd sockaddr size))
 128         (bits-of-sockaddr socket sockaddr))))
 129
 130 ;;; There are a whole bunch of interesting things you can do with a
 131 ;;; socket that don't really map onto "do stream io", especially in
 132 ;;; CL which has no portable concept of a "short read".  socket-receive
 133 ;;; allows us to read from an unconnected socket into a buffer, and
 134 ;;; to learn who the sender of the packet was
 135
 136 (defmethod socket-receive ((socket socket) buffer length
 137                            &key
 138                            oob peek waitall dontwait
 139                            (element-type 'character))
 140   (with-socket-fd-and-addr (fd sockaddr size) socket
 141     (let ((flags
 142            (logior (if oob sockint::MSG-OOB 0)
 143                    (if peek sockint::MSG-PEEK 0)
 144                    (if waitall sockint::MSG-WAITALL 0)
 145                    (if dontwait sockint::MSG-DONTWAIT 0)
 146                    #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
 147                    (if (eql (socket-type socket) :datagram)
 148                        sockint::msg-TRUNC 0))))
 149       (unless (or buffer length)
 150         (error "Must supply at least one of BUFFER or LENGTH"))
 151       (unless length
 152         (setf length (length buffer)))
 153       (when buffer (setf element-type (array-element-type buffer)))
 154       (unless (or (subtypep element-type 'character)
 155                   (subtypep element-type 'integer))
 156         (error "Buffer element-type must be either a character or an integer subtype."))
 157       (unless buffer
 158         (setf buffer (make-array length :element-type element-type)))
 159       ;; really big FIXME: This whole copy-buffer thing is broken.
 160       ;; doesn't support characters more than 8 bits wide, or integer
 161       ;; types that aren't (unsigned-byte 8).
 162       (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
 163         (unwind-protect
 164              (sb-alien:with-alien ((sa-len sockint::socklen-t size))
 165                (socket-error-case ("recvfrom"
 166                                    (sockint::recvfrom fd copy-buffer length
 167                                                       flags sockaddr (sb-alien:addr sa-len))
 168                                    len)
 169                    (progn
 170                      (loop for i from 0 below (min len length)
 171                         do (setf (elt buffer i)
 172                                  (cond
 173                                    ((or (eql element-type 'character) (eql element-type 'base-char))
 174                                     (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
 175                                    (t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
 176                      (apply #'values buffer len (multiple-value-list
 177                                                  (bits-of-sockaddr socket sockaddr))))
 178                  (:interrupted nil)))
 179           (sb-alien:free-alien copy-buffer))))))
 180
 181 (defmacro with-vector-sap ((name vector) &body body)
 182   `(sb-sys:with-pinned-objects (,vector)
 183      (let ((,name (sb-sys:vector-sap ,vector)))
 184        ,@body)))
 185
 186 (defmethod socket-send ((socket socket) buffer length
 187                         &key
 188                         address
 189                         (external-format :default)
 190                         oob eor dontroute dontwait nosignal
 191                         #+linux confirm #+linux more)
 192   (declare (ignorable nosignal))
 193   (let* ((flags
 194           (logior (if oob sockint::MSG-OOB 0)
 195                   (if eor sockint::MSG-EOR 0)
 196                   (if dontroute sockint::MSG-DONTROUTE 0)
 197                   (if dontwait sockint::MSG-DONTWAIT 0)
 198                   #-darwin (if nosignal sockint::MSG-NOSIGNAL 0)
 199                   #+linux (if confirm sockint::MSG-CONFIRM 0)
 200                   #+linux (if more sockint::MSG-MORE 0)))
 201          (buffer (etypecase buffer
 202                    (string
 203                     (sb-ext:string-to-octets buffer
 204                                              :external-format external-format
 205                                              :null-terminate nil))
 206                    ((simple-array (unsigned-byte 8))
 207                     buffer)
 208                    ((array (unsigned-byte 8))
 209                     (make-array (length buffer)
 210                                 :element-type '(unsigned-byte 8)
 211                                 :initial-contents buffer))))
 212          (len (with-vector-sap (buffer-sap buffer)
 213                 (unless length
 214                   (setf length (length buffer)))
 215                 (if address
 216                     (with-socket-fd-and-addr (fd sockaddr size address) socket
 217                       (sb-alien:with-alien ((sa-len sockint::socklen-t size))
 218                         (sockint::sendto fd buffer-sap length
 219                                          flags sockaddr sa-len)))
 220                     (sockint::send (socket-file-descriptor socket)
 221                                    buffer-sap length flags)))))
 222     (socket-error-case ("sendto" len)
 223         len
 224       (:interrupted nil))))
 225
 226 (defmethod socket-listen ((socket socket) backlog)
 227   (socket-error-case
 228       ("listen" (sockint::listen (socket-file-descriptor socket) backlog))))
 229
 230 (defmethod socket-open-p ((socket socket))
 231   (if (slot-boundp socket 'stream)
 232       (open-stream-p (slot-value socket 'stream))
 233       (/= -1 (socket-file-descriptor socket))))
 234
 235 (defmethod socket-close ((socket socket) &key abort)
 236   ;; the close(2) manual page has all kinds of warning about not
 237   ;; checking the return value of close, on the grounds that an
 238   ;; earlier write(2) might have returned successfully w/o actually
 239   ;; writing the stuff to disk.  It then goes on to define the only
 240   ;; possible error return as EBADF (fd isn't a valid open file
 241   ;; descriptor).  Presumably this is an oversight and we could also
 242   ;; get anything that write(2) would have given us.
 243
 244   ;; note that if you have a socket _and_ a stream on the same fd,
 245   ;; the socket will avoid doing anything to close the fd in case
 246   ;; the stream has done it already - if so, it may have been
 247   ;; reassigned to some other file, and closing it would be bad
 248   (let ((fd (socket-file-descriptor socket)))
 249     (flet ((drop-it (&optional streamp)
 250              (setf (slot-value socket 'file-descriptor) -1)
 251              (if streamp
 252                  (slot-makunbound socket 'stream)
 253                  (sb-ext:cancel-finalization socket))
 254              t))
 255       (cond ((eql fd -1)
 256              ;; already closed
 257              nil)
 258            ((slot-boundp socket 'stream)
 259             (close (slot-value socket 'stream) :abort abort)
 260             ;; Don't do this if there was an error from CLOSE -- the stream is
 261             ;; still live.
 262             (drop-it t))
 263            (t
 264             (handler-case
 265                 (socket-error-case ("close" (sockint::close fd)
 266                                             result (minusp result)))
 267               (bad-file-descriptor-error ()
 268                 (drop-it))
 269               (:no-error (r)
 270                 (declare (ignore r))
 271                 (drop-it))))))))
 272
 273 (defmethod socket-shutdown ((socket socket) &key direction)
 274   (let* ((fd  (socket-file-descriptor socket))
 275          (how (ecase direction
 276                 (:input sockint::SHUT_RD)
 277                 (:output sockint::SHUT_WR)
 278                 (:io sockint::SHUT_RDWR))))
 279     (socket-error-case ("shutdown" (sockint::shutdown fd how)
 280                                    result (minusp result)))))
 281
 282 (defmethod socket-make-stream ((socket socket)
 283                                &key input output
 284                                (element-type 'character)
 285                                (buffering :full)
 286                                (external-format :default)
 287                                timeout
 288                                auto-close
 289                                serve-events)
 290   "Default method for SOCKET objects.
 291
 292 ELEMENT-TYPE defaults to CHARACTER, to construct a bivalent stream,
 293 capable of both binary and character IO use :DEFAULT.
 294
 295 Acceptable values for BUFFERING are :FULL, :LINE and :NONE, default
 296 is :FULL, ie. output is buffered till it is explicitly flushed using
 297 CLOSE or FINISH-OUTPUT. (FORCE-OUTPUT forces some output to be
 298 flushed: to ensure all buffered output is flused use FINISH-OUTPUT.)
 299
 300 Streams have no TIMEOUT by default. If one is provided, it is the
 301 number of seconds the system will at most wait for input to appear on
 302 the socket stream when trying to read from it.
 303
 304 If AUTO-CLOSE is true, the underlying OS socket is automatically
 305 closed after the stream and the socket have been garbage collected.
 306 Default is false.
 307
 308 If SERVE-EVENTS is true, blocking IO on the socket will dispatch to
 309 the recursive event loop. Default is false.
 310
 311 The stream for SOCKET will be cached, and a second invocation of this
 312 method will return the same stream. This may lead to oddities if this
 313 function is invoked with inconsistent arguments \(e.g., one might
 314 request an input stream and get an output stream in response\)."
 315   (let ((stream
 316          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
 317     (unless stream
 318       (setf stream (sb-sys:make-fd-stream
 319                     (socket-file-descriptor socket)
 320                     :name (format nil "socket~@[ ~A~]~@[, peer: ~A~]"
 321                                   (socket-namestring socket)
 322                                   (socket-peerstring socket))
 323                     :dual-channel-p t
 324                     :input input
 325                     :output output
 326                     :element-type element-type
 327                     :buffering buffering
 328                     :external-format external-format
 329                     :timeout timeout
 330                     :auto-close auto-close
 331                     :serve-events (and serve-events #+win32 nil)))
 332       (setf (slot-value socket 'stream) stream))
 333     (sb-ext:cancel-finalization socket)
 334     stream))
 335
 336 \f
 337
 338 ;;; Error handling
 339
 340 (define-condition socket-error (error)
 341   ((errno :initform nil
 342           :initarg :errno
 343           :reader socket-error-errno)
 344    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
 345    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
 346   (:report (lambda (c s)
 347              (let ((num (socket-error-errno c)))
 348                (format s "Socket error in \"~A\": ~A (~A)"
 349                        (socket-error-syscall c)
 350                        (or (socket-error-symbol c) (socket-error-errno c))
 351                        #+win32 (sb-win32:format-system-message num)
 352                        #-win32 (sb-int:strerror num)))))
 353   (:documentation "Common base class of socket related conditions."))
 354
 355 ;;; watch out for slightly hacky symbol punning: we use both the value
 356 ;;; and the symbol-name of sockint::efoo
 357
 358 (defmacro define-socket-condition (symbol name)
 359   `(progn
 360      (define-condition ,name (socket-error)
 361        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
 362      (export ',name)
 363      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
 364
 365 (defparameter *conditions-for-errno* nil)
 366 ;;; this needs the rest of the list adding to it, really.  They also
 367 ;;; need symbols to be added to constants.ccon
 368 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
 369 ;;; the same place
 370 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
 371 (define-socket-condition sockint::EAGAIN interrupted-error)
 372 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
 373 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
 374 (define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
 375 (define-socket-condition sockint::EINTR interrupted-error)
 376 (define-socket-condition sockint::EINVAL invalid-argument-error)
 377 (define-socket-condition sockint::ENOBUFS no-buffers-error)
 378 (define-socket-condition sockint::ENOMEM out-of-memory-error)
 379 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
 380 (define-socket-condition sockint::EPERM operation-not-permitted-error)
 381 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
 382 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
 383 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
 384 (define-socket-condition sockint::ENOTCONN not-connected-error)
 385 (define-socket-condition sockint::EAFNOSUPPORT address-family-not-supported)
 386 (define-socket-condition sockint::EINPROGRESS operation-in-progress)
 387
 388 (defun condition-for-errno (err)
 389   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 390
 391 (defun socket-error (where &optional (errno (socket-errno)))
 392   ;; FIXME: Our Texinfo documentation extractor needs at least this to
 393   ;; spit out the signature. Real documentation would be better...
 394   ""
 395   (error (condition-for-errno errno) :errno errno :syscall where))