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                (let ((res (sockint::getprotobyname-r
 110                            name result-buf buffer buffer-length #-solaris result)))
 111                  (cond ((eql res 0)
 112                         #-solaris
 113                         (when (sb-alien::null-alien (sb-alien:deref result 0))
 114                           (error 'unknown-protocol :name name))
 115                         (return-from get-protocol-by-name
 116                           (protoent-to-values result-buf)))
 117                        (t
 118                         (let ((errno (sb-unix::get-errno)))
 119                           (cond ((eql errno sockint::erange)
 120                                  (incf buffer-length 1024)
 121                                  (when (> buffer-length max-buffer)
 122                                    (error "Exceeded max-buffer of ~d" max-buffer)))
 123                                 (t
 124                                  (error "Unexpected errno ~d" errno))))))))
 125           (when result-buf
 126             (sb-alien:free-alien result-buf))
 127           (when buffer
 128             (sb-alien:free-alien buffer))
 129           #-solaris
 130           (when result
 131             (sb-alien:free-alien result)))))
 132     #-(and sb-thread os-provides-getprotoby-r)
 133     (tagbody
 134        (flet ((get-it ()
 135                 (let ((ent (sockint::getprotobyname name)))
 136                   (if (sb-alien::null-alien ent)
 137                       (go :error)
 138                       (return-from get-protocol-by-name (protoent-to-values ent))))))
 139          #+sb-thread
 140          (sb-thread::with-system-mutex (**getprotoby-lock**)
 141            (get-it))
 142          #-sb-thread
 143          (get-it))
 144      :error
 145        (error 'unknown-protocol :name name))))
 146
 147 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
 148 ;;; bits-of-sockaddr
 149
 150 (defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address)))
 151   (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
 152     (when (and host port)
 153       (setf host (coerce host '(simple-array (unsigned-byte 8) (4))))
 154       ;; port and host are represented in C as "network-endian" unsigned
 155       ;; integers of various lengths.  This is stupid.  The value of the
 156       ;; integer doesn't matter (and will change depending on your
 157       ;; machine's endianness); what the bind(2) call is interested in
 158       ;; is the pattern of bytes within that integer.
 159
 160       ;; We have no truck with such dreadful type punning.  Octets to
 161       ;; octets, dust to dust.
 162
 163       (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
 164       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0) (ldb (byte 8 8) port))
 165       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1) (ldb (byte 8 0) port))
 166
 167       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 0) (elt host 0))
 168       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 1) (elt host 1))
 169       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 2) (elt host 2))
 170       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 3) (elt host 3)))
 171     sockaddr))
 172
 173 (defmethod free-sockaddr-for ((socket inet-socket) sockaddr)
 174   (sockint::free-sockaddr-in sockaddr))
 175
 176 (defmethod size-of-sockaddr ((socket inet-socket))
 177   sockint::size-of-sockaddr-in)
 178
 179 (defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
 180   "Returns address and port of SOCKADDR as multiple values"
 181   (values
 182    (coerce (loop for i from 0 below 4
 183                  collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i))
 184            '(vector (unsigned-byte 8) 4))
 185    (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
 186       (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1))))
 187
 188 (defun make-inet-socket (type protocol)
 189   "Make an INET socket.  Deprecated in favour of make-instance"
 190   (make-instance 'inet-socket :type type :protocol protocol))