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 #|| <h2>SOCKETs</h2>
   7
   8 |#
   9
  10 (eval-when (:load-toplevel :compile-toplevel :execute)
  11 (defclass socket ()
  12   ((file-descriptor :initarg :descriptor
  13                     :reader socket-file-descriptor)
  14    (family :initform (error "No socket family") :reader socket-family)
  15    (protocol :initarg :protocol :reader socket-protocol)
  16    (type  :initarg :type :reader socket-type)
  17    (stream))))
  18
  19 (defmethod print-object ((object socket) stream)
  20   (print-unreadable-object (object stream :type t :identity t)
  21                            (princ "descriptor " stream)
  22                            (princ (slot-value object 'file-descriptor) stream)))
  23
  24
  25 (defmethod shared-initialize :after ((socket socket) slot-names
  26                                      &key protocol type
  27                                      &allow-other-keys)
  28   (let* ((proto-num
  29           (cond ((and protocol (keywordp protocol))
  30                  (get-protocol-by-name (string-downcase (symbol-name protocol))))
  31                 (protocol protocol)
  32                 (t 0)))
  33          (fd (or (and (slot-boundp socket 'file-descriptor)
  34                       (socket-file-descriptor socket))
  35                  (sockint::socket (socket-family socket)
  36                                   (ecase type
  37                                     ((:datagram) sockint::sock-dgram)
  38                                     ((:stream) sockint::sock-stream))
  39                                   proto-num))))
  40       (if (= fd -1) (socket-error "socket"))
  41       (setf (slot-value socket 'file-descriptor) fd
  42             (slot-value socket 'protocol) proto-num
  43             (slot-value socket 'type) type)
  44       (sb-ext:finalize socket (lambda () (sockint::close fd)))))
  45
  46 \f
  47
  48 (defgeneric make-sockaddr-for (socket &optional sockaddr &rest address)
  49   (:documentation "Return a Socket Address object suitable for use with SOCKET.
  50 When SOCKADDR is passed, it is used instead of a new object."))
  51
  52 ;; we deliberately redesign the "bind" interface: instead of passing a
  53 ;; sockaddr_something as second arg, we pass the elements of one as
  54 ;; multiple arguments.
  55
  56 (defgeneric socket-bind (socket &rest address)
  57   (:documentation "Bind SOCKET to ADDRESS, which may vary according to
  58 socket family.  For the INET family, pass ADDRESS and PORT as two
  59 arguments; for FILE address family sockets, pass the filename string.
  60 See also bind(2)"))
  61
  62 (defmethod socket-bind ((socket socket)
  63                         &rest address)
  64   (let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
  65     (if (= (sb-sys:without-gcing
  66             (sockint::bind (socket-file-descriptor socket)
  67                            (sockint::array-data-address sockaddr)
  68                            (size-of-sockaddr socket)))
  69            -1)
  70         (socket-error "bind"))))
  71
  72 \f
  73 (defgeneric socket-accept (socket)
  74   (:documentation "Perform the accept(2) call, returning a
  75 newly-created connected socket and the peer address as multiple
  76 values"))
  77
  78 (defmethod socket-accept ((socket socket))
  79   (let* ((sockaddr (make-sockaddr-for socket))
  80          (fd (sb-sys:without-gcing
  81               (sockint::accept (socket-file-descriptor socket)
  82                                (sockint::array-data-address sockaddr)
  83                                (size-of-sockaddr socket)))))
  84     (apply #'values
  85            (if (= fd -1)
  86                (socket-error "accept")
  87                (let ((s (make-instance (class-of socket)
  88                                        :type (socket-type socket)
  89                                        :protocol (socket-protocol socket)
  90                                        :descriptor fd)))
  91                  (sb-ext:finalize s (lambda () (sockint::close fd)))))
  92            (multiple-value-list (bits-of-sockaddr socket sockaddr)))))
  93
  94 (defgeneric socket-connect (socket &rest address)
  95   (:documentation "Perform the connect(2) call to connect SOCKET to a
  96   remote PEER.  No useful return value."))
  97
  98 (defmethod socket-connect ((socket socket) &rest peer)
  99   (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
 100     (if (= (sb-sys:without-gcing
 101             (sockint::connect (socket-file-descriptor socket)
 102                               (sockint::array-data-address sockaddr)
 103                               (size-of-sockaddr socket)))
 104            -1)
 105         (socket-error "connect") )))
 106
 107 (defgeneric socket-peername (socket)
 108   (:documentation "Return the socket's peer; depending on the address
 109   family this may return multiple values"))
 110
 111 (defmethod socket-peername ((socket socket))
 112   (let* ((sockaddr (make-sockaddr-for socket)))
 113     (when (= (sb-sys:without-gcing
 114               (sockint::getpeername (socket-file-descriptor socket)
 115                                     (sockint::array-data-address sockaddr)
 116                                     (size-of-sockaddr socket)))
 117              -1)
 118       (socket-error "getpeername"))
 119     (bits-of-sockaddr socket sockaddr)))
 120
 121 (defgeneric socket-name (socket)
 122   (:documentation "Return the address (as vector of bytes) and port
 123   that the socket is bound to, as multiple values."))
 124
 125 (defmethod socket-name ((socket socket))
 126   (let* ((sockaddr (make-sockaddr-for socket)))
 127     (when (= (sb-sys:without-gcing
 128               (sockint::getsockname (socket-file-descriptor socket)
 129                                     (sockint::array-data-address sockaddr)
 130                                     (size-of-sockaddr socket)))
 131              -1)
 132       (socket-error "getsockname"))
 133     (bits-of-sockaddr socket sockaddr)))
 134
 135
 136 ;;; There are a whole bunch of interesting things you can do with a
 137 ;;; socket that don't really map onto "do stream io", especially in
 138 ;;; CL which has no portable concept of a "short read".  socket-receive
 139 ;;; allows us to read from an unconnected socket into a buffer, and
 140 ;;; to learn who the sender of the packet was
 141
 142 (defgeneric socket-receive (socket buffer length
 143                             &key
 144                             oob peek waitall element-type)
 145   (:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
 146 NIL), using recvfrom(2).  If LENGTH is NIL, the length of BUFFER is
 147 used, so at least one of these two arguments must be non-NIL.  If
 148 BUFFER is supplied, it had better be of an element type one octet wide.
 149 Returns the buffer, its length, and the address of the peer
 150 that sent it, as multiple values.  On datagram sockets, sets MSG_TRUNC
 151 so that the actual packet length is returned even if the buffer was too
 152 small"))
 153
 154 (defmethod socket-receive ((socket socket) buffer length
 155                          &key
 156                          oob peek waitall
 157                          (element-type 'character))
 158   (let ((flags
 159          (logior (if oob sockint::MSG-OOB 0)
 160                  (if peek sockint::MSG-PEEK 0)
 161                  (if waitall sockint::MSG-WAITALL 0)
 162                  sockint::MSG-NOSIGNAL  ;don't send us SIGPIPE
 163                  (if (eql (socket-type socket) :datagram)
 164                      sockint::msg-TRUNC 0)))
 165         (sockaddr (make-sockaddr-for socket)))
 166     (unless (or buffer length)
 167       (error "Must supply at least one of BUFFER or LENGTH"))
 168     (unless buffer
 169       (setf buffer (make-array length :element-type element-type)))
 170     (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
 171       (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
 172       (sb-sys:without-gcing
 173        (let ((len
 174               (sockint::recvfrom (socket-file-descriptor socket)
 175                                  (sockint::array-data-address buffer)
 176                                  (or length (length buffer))
 177                                  flags
 178                                  (sockint::array-data-address sockaddr)
 179                                  (sb-alien:cast sa-len (* integer)))))
 180          (when (= len -1) (socket-error "recvfrom"))
 181          (apply #'values buffer len (multiple-value-list
 182                                      (bits-of-sockaddr socket sockaddr))))))))
 183
 184
 185
 186 (defgeneric socket-listen (socket backlog)
 187   (:documentation "Mark SOCKET as willing to accept incoming connections.  BACKLOG
 188 defines the maximum length that the queue of pending connections may
 189 grow to before new connection attempts are refused.  See also listen(2)"))
 190
 191 (defmethod socket-listen ((socket socket) backlog)
 192   (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
 193     (if (= r -1)
 194         (socket-error "listen"))))
 195
 196 (defgeneric socket-close (socket)
 197   (:documentation "Close SOCKET.  May throw any kind of error that write(2) would have
 198 thrown.  If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
 199 stream instead"))
 200
 201 (defmethod socket-close ((socket socket))
 202   ;; the close(2) manual page has all kinds of warning about not
 203   ;; checking the return value of close, on the grounds that an
 204   ;; earlier write(2) might have returned successfully w/o actually
 205   ;; writing the stuff to disk.  It then goes on to define the only
 206   ;; possible error return as EBADF (fd isn't a valid open file
 207   ;; descriptor).  Presumably this is an oversight and we could also
 208   ;; get anything that write(2) would have given us.
 209
 210   ;; What we do: we catch EBADF.  It should only ever happen if
 211   ;; (a) someone's closed the socket already (stream closing seems
 212   ;; to have this effect) or (b) the caller is messing around with
 213   ;; socket internals.  That's not supported, dude
 214
 215   (if (slot-boundp socket 'stream)
 216       (close (slot-value socket 'stream))  ;; closes socket as well
 217     (handler-case
 218      (if (= (sockint::close (socket-file-descriptor socket)) -1)
 219          (socket-error "close"))
 220      (bad-file-descriptor-error (c) (declare (ignore c)) nil)
 221      (:no-error (c)  (declare (ignore c)) nil))))
 222
 223 (defgeneric socket-make-stream (socket  &rest args)
 224     (:documentation "Find or create a STREAM that can be used for IO
 225 on SOCKET (which must be connected).  ARGS are passed onto
 226 SB-SYS:MAKE-FD-STREAM."))
 227
 228 (defmethod socket-make-stream ((socket socket)  &rest args)
 229   (let ((stream
 230          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
 231     (unless stream
 232       (setf stream (apply #'sb-sys:make-fd-stream
 233                           (socket-file-descriptor socket) args))
 234       (setf (slot-value socket 'stream) stream)
 235       (sb-ext:cancel-finalization socket))
 236     stream))
 237
 238 \f
 239
 240 ;;; Error handling
 241
 242 (define-condition socket-error (error)
 243   ((errno :initform nil
 244           :initarg :errno
 245           :reader socket-error-errno)
 246    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
 247    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
 248   (:report (lambda (c s)
 249              (let ((num (socket-error-errno c)))
 250                (format s "Socket error in \"~A\": ~A (~A)"
 251                        (socket-error-syscall c)
 252                        (or (socket-error-symbol c) (socket-error-errno c))
 253                        #+cmu (sb-unix:get-unix-error-msg num)
 254                        #+sbcl (sb-int:strerror num))))))
 255
 256 ;;; watch out for slightly hacky symbol punning: we use both the value
 257 ;;; and the symbol-name of sockint::efoo
 258
 259 (defmacro define-socket-condition (symbol name)
 260   `(progn
 261      (define-condition ,name (socket-error)
 262        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
 263      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
 264
 265 (defparameter *conditions-for-errno* nil)
 266 ;;; this needs the rest of the list adding to it, really.  They also
 267 ;;; need
 268 ;;; - conditions to be exported in the DEFPACKAGE form
 269 ;;; - symbols to be added to constants.ccon
 270 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
 271 ;;; the same place
 272 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
 273 (define-socket-condition sockint::EAGAIN interrupted-error)
 274 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
 275 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
 276 (define-socket-condition sockint::EINTR interrupted-error)
 277 (define-socket-condition sockint::EINVAL invalid-argument-error)
 278 (define-socket-condition sockint::ENOBUFS no-buffers-error)
 279 (define-socket-condition sockint::ENOMEM out-of-memory-error)
 280 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
 281 (define-socket-condition sockint::EPERM operation-not-permitted-error)
 282 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
 283 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
 284 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
 285
 286
 287 (defun condition-for-errno (err)
 288   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 289
 290 #+cmu
 291 (defun socket-error (where)
 292   ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
 293   ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
 294   ;; to update the value that unix-errno looks at.  On other CMUCL
 295   ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
 296   (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
 297   (let ((condition (condition-for-errno sb-unix:unix-errno)))
 298     (error condition :errno sb-unix:unix-errno  :syscall where)))
 299
 300 #+sbcl
 301 (defun socket-error (where)
 302   (let* ((errno  (sb-unix::get-errno))
 303          (condition (condition-for-errno errno)))
 304     (error condition :errno errno  :syscall where)))
 305
 306
 307 (defgeneric bits-of-sockaddr (socket sockaddr)
 308   (:documentation "Return protocol-dependent bits of parameter
 309 SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
 310
 311 (defgeneric size-of-sockaddr (socket)
 312   (:documentation "Return the size of a sockaddr object for SOCKET."))