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