contrib/sb-bsd-sockets/inet.lisp

   1 (in-package :sb-bsd-sockets)
   2
   3 ;;; Our class and constructor
   4
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6   (defclass inet-socket (socket)
   7     ((family :initform sockint::AF-INET))
   8     (:documentation "Class representing TCP and UDP sockets.
   9
  10 Examples:
  11
  12  (make-instance 'inet-socket :type :stream :protocol :tcp)
  13
  14  (make-instance 'inet-socket :type :datagram :protocol :udp)
  15 ")))
  16
  17 ;;; XXX should we *...* this?
  18 (defparameter inet-address-any (vector 0 0 0 0))
  19
  20 (defmethod socket-namestring ((socket inet-socket))
  21   (ignore-errors
  22     (multiple-value-bind (addr port) (socket-name socket)
  23       (format nil "~{~A~^.~}:~A" (coerce addr 'list) port))))
  24
  25 (defmethod socket-peerstring ((socket inet-socket))
  26   (ignore-errors
  27     (multiple-value-bind (addr port) (socket-peername socket)
  28       (format nil "~{~A~^.~}:~A" (coerce addr 'list) port))))
  29
  30 ;;; binding a socket to an address and port.  Doubt that anyone's
  31 ;;; actually using this much, to be honest.
  32
  33 (defun make-inet-address (dotted-quads)
  34   "Return a vector of octets given a string DOTTED-QUADS in the format
  35 \"127.0.0.1\". Signals an error if the string is malformed."
  36   (declare (type string dotted-quads))
  37   (labels ((oops ()
  38              (error "~S is not a string designating an IP address."
  39                     dotted-quads))
  40            (check (x)
  41              (if (typep x '(unsigned-byte 8))
  42                  x
  43                  (oops))))
  44     (let* ((s1 (position #\. dotted-quads))
  45            (s2 (if s1 (position #\. dotted-quads :start (1+ s1)) (oops)))
  46            (s3 (if s2 (position #\. dotted-quads :start (1+ s2)) (oops)))
  47            (u0 (parse-integer dotted-quads :end s1))
  48            (u1 (parse-integer dotted-quads :start (1+ s1) :end s2))
  49            (u2 (parse-integer dotted-quads :start (1+ s2) :end s3)))
  50       (multiple-value-bind (u3 end) (parse-integer dotted-quads :start (1+ s3) :junk-allowed t)
  51         (unless (= end (length dotted-quads))
  52           (oops))
  53         (let ((vector (make-array 4 :element-type '(unsigned-byte 8))))
  54           (setf (aref vector 0) (check u0)
  55                 (aref vector 1) (check u1)
  56                 (aref vector 2) (check u2)
  57                 (aref vector 3) (check u3))
  58           vector)))))
  59
  60 (define-condition unknown-protocol ()
  61   ((name :initarg :name
  62          :reader unknown-protocol-name))
  63   (:report (lambda (c s)
  64              (format s "Protocol not found: ~a" (prin1-to-string
  65                                                  (unknown-protocol-name c))))))
  66
  67 #+(and sb-thread (not os-provides-getprotoby-r))
  68 ;; Since getprotobyname is not thread-safe, we need a lock.
  69 (sb-ext:defglobal **getprotoby-lock** (sb-thread:make-mutex :name "getprotoby lock"))
  70
  71 ;;; getprotobyname only works in the internet domain, which is why this
  72 ;;; is here
  73 (defun get-protocol-by-name (name)      ;exported
  74   "Given a protocol name, return the protocol number, the protocol name, and
  75 a list of protocol aliases"
  76
  77   ;; Brownie Points.  Hopefully there's one person out there using
  78   ;; RSPF sockets and SBCL who will appreciate the extra info
  79   (labels ((protoent-to-values (protoent)
  80              (values
  81               (sockint::protoent-proto protoent)
  82               (sockint::protoent-name protoent)
  83               (let ((index 0))
  84                 (loop
  85                   for alias = (sb-alien:deref
  86                                (sockint::protoent-aliases protoent) index)
  87                   while (not (sb-alien:null-alien alias))
  88                   do (incf index)
  89                   collect (sb-alien::c-string-to-string
  90                            (sb-alien:alien-sap alias)
  91                            (sb-impl::default-external-format)
  92                            'character))))))
  93     #+(and sb-thread os-provides-getprotoby-r)
  94     (let ((buffer-length 1024)
  95           (max-buffer 10000)
  96           (result-buf nil)
  97           (buffer nil)
  98           #-solaris
  99           (result nil))
 100       (declare (type fixnum buffer-length)
 101                (type fixnum max-buffer))
 102       (loop
 103         (unwind-protect
 104              (progn
 105                (setf result-buf (sb-alien:make-alien sockint::protoent)
 106                      buffer (sb-alien:make-alien sb-alien:char buffer-length))
 107                #-solaris
 108                (setf result (sb-alien:make-alien (* sockint::protoent)))
 109                (when (or (sb-alien:null-alien result-buf)
 110                          (sb-alien:null-alien buffer)
 111                          (sb-alien:null-alien result))
 112                  (error "Could not allocate foreign memory."))
 113                (let ((res (sockint::getprotobyname-r
 114                            name result-buf buffer buffer-length #-solaris result)))
 115                  (cond ((eql res 0)
 116                         #-solaris
 117                         (when (sb-alien::null-alien (sb-alien:deref result 0))
 118                           (error 'unknown-protocol :name name))
 119                         (return-from get-protocol-by-name
 120                           (protoent-to-values result-buf)))
 121                        (t
 122                         (let ((errno (sb-unix::get-errno)))
 123                           (cond ((eql errno sockint::erange)
 124                                  (incf buffer-length 1024)
 125                                  (when (> buffer-length max-buffer)
 126                                    (error "Exceeded max-buffer of ~d" max-buffer)))
 127                                 (t
 128                                  (error "Unexpected errno ~d" errno))))))))
 129           (when result-buf
 130             (sb-alien:free-alien result-buf))
 131           (when buffer
 132             (sb-alien:free-alien buffer))
 133           #-solaris
 134           (when result
 135             (sb-alien:free-alien result)))))
 136     #-(and sb-thread os-provides-getprotoby-r)
 137     (tagbody
 138        (flet ((get-it ()
 139                 (let ((ent (sockint::getprotobyname name)))
 140                   (if (sb-alien::null-alien ent)
 141                       (go :error)
 142                       (return-from get-protocol-by-name (protoent-to-values ent))))))
 143          #+sb-thread
 144          (sb-thread::with-system-mutex (**getprotoby-lock**)
 145            (get-it))
 146          #-sb-thread
 147          (get-it))
 148      :error
 149        (error 'unknown-protocol :name name))))
 150
 151 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
 152 ;;; bits-of-sockaddr
 153
 154 (defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address)))
 155   (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
 156     (when (and host port)
 157       (setf host (coerce host '(simple-array (unsigned-byte 8) (4))))
 158       ;; port and host are represented in C as "network-endian" unsigned
 159       ;; integers of various lengths.  This is stupid.  The value of the
 160       ;; integer doesn't matter (and will change depending on your
 161       ;; machine's endianness); what the bind(2) call is interested in
 162       ;; is the pattern of bytes within that integer.
 163
 164       ;; We have no truck with such dreadful type punning.  Octets to
 165       ;; octets, dust to dust.
 166
 167       (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
 168       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0) (ldb (byte 8 8) port))
 169       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1) (ldb (byte 8 0) port))
 170
 171       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 0) (elt host 0))
 172       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 1) (elt host 1))
 173       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 2) (elt host 2))
 174       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 3) (elt host 3)))
 175     sockaddr))
 176
 177 (defmethod free-sockaddr-for ((socket inet-socket) sockaddr)
 178   (sockint::free-sockaddr-in sockaddr))
 179
 180 (defmethod size-of-sockaddr ((socket inet-socket))
 181   sockint::size-of-sockaddr-in)
 182
 183 (defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
 184   "Returns address and port of SOCKADDR as multiple values"
 185   (values
 186    (coerce (loop for i from 0 below 4
 187                  collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i))
 188            '(vector (unsigned-byte 8) 4))
 189    (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
 190       (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1))))
 191
 192 (defun make-inet-socket (type protocol)
 193   "Make an INET socket.  Deprecated in favour of make-instance"
 194   (make-instance 'inet-socket :type type :protocol protocol))