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 element-type)
 160   (:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
 161 NIL), using recvfrom(2).  If LENGTH is NIL, the length of BUFFER is
 162 used, so at least one of these two arguments must be non-NIL.  If
 163 BUFFER is supplied, it had better be of an element type one octet wide.
 164 Returns the buffer, its length, and the address of the peer
 165 that sent it, as multiple values.  On datagram sockets, sets MSG_TRUNC
 166 so that the actual packet length is returned even if the buffer was too
 167 small"))
 168
 169 (defmethod socket-receive ((socket socket) buffer length
 170                            &key
 171                            oob peek waitall
 172                            (element-type 'character))
 173   (with-sockaddr-for (socket sockaddr)
 174     (let ((flags
 175            (logior (if oob sockint::MSG-OOB 0)
 176                    (if peek sockint::MSG-PEEK 0)
 177                    (if waitall sockint::MSG-WAITALL 0)
 178                    #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
 179                    (if (eql (socket-type socket) :datagram)
 180                        sockint::msg-TRUNC 0))))
 181       (unless (or buffer length)
 182         (error "Must supply at least one of BUFFER or LENGTH"))
 183       (unless length
 184         (setf length (length buffer)))
 185       (when buffer (setf element-type (array-element-type buffer)))
 186       (unless (or (subtypep element-type 'character)
 187                   (subtypep element-type 'integer))
 188         (error "Buffer element-type must be either a character or an integer subtype."))
 189       (unless buffer
 190         (setf buffer (make-array length :element-type element-type)))
 191       ;; really big FIXME: This whole copy-buffer thing is broken.
 192       ;; doesn't support characters more than 8 bits wide, or integer
 193       ;; types that aren't (unsigned-byte 8).
 194       (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
 195         (unwind-protect
 196             (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket)))
 197               (let ((len
 198                      (sockint::recvfrom (socket-file-descriptor socket)
 199                                         copy-buffer
 200                                         length
 201                                         flags
 202                                         sockaddr
 203                                         (sb-alien:addr sa-len))))
 204                 (cond
 205                   ((and (= len -1)
 206                         (member (sb-unix::get-errno)
 207                                 (list sockint::EAGAIN sockint::EINTR)))
 208                    nil)
 209                   ((= len -1) (socket-error "recvfrom"))
 210                   (t (loop for i from 0 below len
 211                            do (setf (elt buffer i)
 212                                     (cond
 213                                       ((or (eql element-type 'character) (eql element-type 'base-char))
 214                                        (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
 215                                       (t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
 216                      (apply #'values buffer len (multiple-value-list
 217                                                  (bits-of-sockaddr socket sockaddr)))))))
 218           (sb-alien:free-alien copy-buffer))))))
 219
 220 (defmacro with-vector-sap ((name vector) &body body)
 221   `(sb-sys:with-pinned-objects (,vector)
 222      (let ((,name (sb-sys:vector-sap ,vector)))
 223        ,@body)))
 224
 225 (defgeneric socket-send (socket buffer length
 226                                 &key
 227                                 address
 228                                 external-format
 229                                 oob eor dontroute dontwait nosignal
 230                                 #+linux confirm #+linux more)
 231   (:documentation
 232    "Send LENGTH octets from BUFFER into SOCKET, using sendto(2). If BUFFER
 233 is a string, it will converted to octets according to EXTERNAL-FORMAT. If
 234 LENGTH is NIL, the length of the octet buffer is used. The format of ADDRESS
 235 depends on the socket type (for example for INET domain sockets it would
 236 be a list of an IP address and a port). If no socket address is provided,
 237 send(2) will be called instead. Returns the number of octets written."))
 238
 239 (defmethod socket-send ((socket socket) buffer length
 240                         &key
 241                         address
 242                         (external-format :default)
 243                         oob eor dontroute dontwait nosignal
 244                         #+linux confirm #+linux more)
 245   (let* ((flags
 246           (logior (if oob sockint::MSG-OOB 0)
 247                   (if eor sockint::MSG-EOR 0)
 248                   (if dontroute sockint::MSG-DONTROUTE 0)
 249                   (if dontwait sockint::MSG-DONTWAIT 0)
 250                   (if nosignal sockint::MSG-NOSIGNAL 0)
 251                   #+linux (if confirm sockint::MSG-CONFIRM 0)
 252                   #+linux (if more sockint::MSG-MORE 0)))
 253          (buffer (etypecase buffer
 254                    (string
 255                     (sb-ext:string-to-octets buffer
 256                                              :external-format external-format
 257                                              :null-terminate nil))
 258                    ((simple-array (unsigned-byte 8))
 259                     buffer)
 260                    ((array (unsigned-byte 8))
 261                     (make-array (length buffer)
 262                                 :element-type '(unsigned-byte 8)
 263                                 :initial-contents buffer))))
 264          (len (with-vector-sap (buffer-sap buffer)
 265                 (unless length
 266                   (setf length (length buffer)))
 267                 (if address
 268                     (with-sockaddr-for (socket sockaddr address)
 269                       (sb-alien:with-alien ((sa-len sockint::socklen-t
 270                                                     (size-of-sockaddr socket)))
 271                         (sockint::sendto (socket-file-descriptor socket)
 272                                          buffer-sap
 273                                          length
 274                                          flags
 275                                          sockaddr
 276                                          sa-len)))
 277                     (sockint::send (socket-file-descriptor socket)
 278                                    buffer-sap
 279                                    length
 280                                    flags)))))
 281     (cond
 282       ((and (= len -1)
 283             (member (sb-unix::get-errno)
 284                     (list sockint::EAGAIN sockint::EINTR)))
 285        nil)
 286       ((= len -1)
 287        (socket-error "sendto"))
 288       (t len))))
 289
 290 (defgeneric socket-listen (socket backlog)
 291   (:documentation "Mark SOCKET as willing to accept incoming connections.  BACKLOG
 292 defines the maximum length that the queue of pending connections may
 293 grow to before new connection attempts are refused.  See also listen(2)"))
 294
 295 (defmethod socket-listen ((socket socket) backlog)
 296   (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
 297     (if (= r -1)
 298         (socket-error "listen"))))
 299
 300 (defgeneric socket-open-p (socket)
 301   (:documentation "Return true if SOCKET is open; otherwise, return false.")
 302   (:method ((socket t)) (error 'type-error
 303                                :datum socket :expected-type 'socket)))
 304
 305 (defmethod socket-open-p ((socket socket))
 306   (if (slot-boundp socket 'stream)
 307       (open-stream-p (slot-value socket 'stream))
 308       (/= -1 (socket-file-descriptor socket))))
 309
 310 (defgeneric socket-close (socket)
 311   (:documentation "Close SOCKET.  May throw any kind of error that
 312 write(2) would have thrown.  If SOCKET-MAKE-STREAM has been called,
 313 calls CLOSE on that stream instead"))
 314
 315 (defmethod socket-close ((socket socket))
 316   ;; the close(2) manual page has all kinds of warning about not
 317   ;; checking the return value of close, on the grounds that an
 318   ;; earlier write(2) might have returned successfully w/o actually
 319   ;; writing the stuff to disk.  It then goes on to define the only
 320   ;; possible error return as EBADF (fd isn't a valid open file
 321   ;; descriptor).  Presumably this is an oversight and we could also
 322   ;; get anything that write(2) would have given us.
 323
 324   ;; note that if you have a socket _and_ a stream on the same fd,
 325   ;; the socket will avoid doing anything to close the fd in case
 326   ;; the stream has done it already - if so, it may have been
 327   ;; reassigned to some other file, and closing it would be bad
 328
 329   (let ((fd (socket-file-descriptor socket)))
 330     (cond ((eql fd -1) ; already closed
 331            nil)
 332           ((slot-boundp socket 'stream)
 333            (unwind-protect (close (slot-value socket 'stream)) ;; closes fd
 334              (setf (slot-value socket 'file-descriptor) -1)
 335              (slot-makunbound socket 'stream)))
 336           (t
 337            (sb-ext:cancel-finalization socket)
 338            (handler-case
 339                (if (= (sockint::close fd) -1)
 340                    (socket-error "close"))
 341              (bad-file-descriptor-error (c) (declare (ignore c)) nil)
 342              (:no-error (c)
 343                (declare (ignore c))
 344                (setf (slot-value socket 'file-descriptor) -1)
 345                nil))))))
 346
 347
 348 (defgeneric socket-make-stream (socket &rest args)
 349   (:documentation "Find or create a STREAM that can be used for IO on
 350 SOCKET (which must be connected).  ARGS are passed onto
 351 SB-SYS:MAKE-FD-STREAM."))
 352
 353 (defmethod socket-make-stream ((socket socket) &rest args)
 354   (let ((stream
 355          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
 356     (unless stream
 357       (setf stream (apply #'sb-sys:make-fd-stream
 358                           (socket-file-descriptor socket)
 359                           :name "a socket"
 360                           :dual-channel-p t
 361                           args))
 362       (setf (slot-value socket 'stream) stream)
 363       (sb-ext:cancel-finalization socket))
 364     stream))
 365
 366 \f
 367
 368 ;;; Error handling
 369
 370 (define-condition socket-error (error)
 371   ((errno :initform nil
 372           :initarg :errno
 373           :reader socket-error-errno)
 374    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
 375    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
 376   (:report (lambda (c s)
 377              (let ((num (socket-error-errno c)))
 378                (format s "Socket error in \"~A\": ~A (~A)"
 379                        (socket-error-syscall c)
 380                        (or (socket-error-symbol c) (socket-error-errno c))
 381                        #+cmu (sb-unix:get-unix-error-msg num)
 382                        #+sbcl (sb-int:strerror num)))))
 383   (:documentation "Common base class of socket related conditions."))
 384
 385 ;;; watch out for slightly hacky symbol punning: we use both the value
 386 ;;; and the symbol-name of sockint::efoo
 387
 388 (defmacro define-socket-condition (symbol name)
 389   `(progn
 390      (define-condition ,name (socket-error)
 391        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
 392      (export ',name)
 393      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
 394
 395 (defparameter *conditions-for-errno* nil)
 396 ;;; this needs the rest of the list adding to it, really.  They also
 397 ;;; need symbols to be added to constants.ccon
 398 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
 399 ;;; the same place
 400 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
 401 (define-socket-condition sockint::EAGAIN interrupted-error)
 402 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
 403 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
 404 (define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
 405 (define-socket-condition sockint::EINTR interrupted-error)
 406 (define-socket-condition sockint::EINVAL invalid-argument-error)
 407 (define-socket-condition sockint::ENOBUFS no-buffers-error)
 408 (define-socket-condition sockint::ENOMEM out-of-memory-error)
 409 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
 410 (define-socket-condition sockint::EPERM operation-not-permitted-error)
 411 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
 412 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
 413 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
 414 (define-socket-condition sockint::ENOTCONN not-connected-error)
 415
 416 (defun condition-for-errno (err)
 417   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 418
 419 #+cmu
 420 (defun socket-error (where)
 421   ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
 422   ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
 423   ;; to update the value that unix-errno looks at.  On other CMUCL
 424   ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
 425   (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
 426   (let ((condition (condition-for-errno sb-unix:unix-errno)))
 427     (error condition :errno sb-unix:unix-errno  :syscall where)))
 428
 429 #+sbcl
 430 (defun socket-error (where)
 431   ;; FIXME: Our Texinfo documentation extracter need at least his to spit
 432   ;; out the signature. Real documentation would be better...
 433   ""
 434   (let* ((errno  (sb-unix::get-errno))
 435          (condition (condition-for-errno errno)))
 436     (error condition :errno errno  :syscall where)))
 437
 438
 439 (defgeneric bits-of-sockaddr (socket sockaddr)
 440   (:documentation "Return protocol-dependent bits of parameter
 441 SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
 442
 443 (defgeneric size-of-sockaddr (socket)
 444   (:documentation "Return the size of a sockaddr object for SOCKET."))