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
  75   ;; Brownie Points.  Hopefully there's one person out there using
  76   ;; RSPF sockets and SBCL who will appreciate the extra info
  77   (labels ((protoent-to-values (protoent)
  78              (values
  79               (sockint::protoent-proto protoent)
  80               (sockint::protoent-name protoent)
  81               (let ((index 0))
  82                 (loop
  83                    for alias = (sb-alien:deref (sockint::protoent-aliases protoent) index)
  84                    while (not (sb-alien:null-alien alias))
  85                    do (incf index)
  86                    collect (sb-alien::c-string-to-string (sb-alien:alien-sap alias)
  87                                                          (sb-impl::default-external-format)
  88                                                          'character))))))
  89     #+(and sb-thread os-provides-getprotoby-r)
  90     (let ((buffer-length 1024)
  91           (max-buffer 10000))
  92       (declare (type fixnum buffer-length)
  93                (type fixnum max-buffer))
  94       (loop
  95          (sb-alien:with-alien ((result-buf (* sockint::protoent)
  96                                            (sb-alien:make-alien sockint::protoent))
  97                                (buffer (* char )
  98                                        (sb-alien:make-alien sb-alien:char buffer-length))
  99                                #-solaris
 100                                (result (* (* sockint::protoent))
 101                                        (sb-alien:make-alien (* sockint::protoent))))
 102
 103            (let ((res (sockint::getprotobyname-r name
 104                                                  result-buf
 105                                                  buffer
 106                                                  buffer-length
 107                                                  #-solaris
 108                                                  result)))
 109              (if (eql res 0)
 110                  (progn
 111                    #-solaris
 112                    (when (sb-alien::null-alien (sb-alien:deref result 0))
 113                      (error 'unknown-protocol :name name))
 114                    (return-from get-protocol-by-name
 115                      (protoent-to-values result-buf)))
 116                  (let ((errno (sb-unix::get-errno)))
 117                    (if (eql errno  sockint::erange)
 118                        (progn
 119                          (incf buffer-length 1024)
 120                          (if (> buffer-length max-buffer)
 121                              (error "Exceeded max-buffer of ~d" max-buffer)))
 122                        (error "Unexpected errno ~d" errno))))))))
 123     #-(and sb-thread os-provides-getprotoby-r)
 124     (tagbody
 125        (flet ((get-it ()
 126                 (let ((ent (sockint::getprotobyname name)))
 127                   (if (sb-alien::null-alien ent)
 128                       (go :error)
 129                       (return-from get-protocol-by-name (protoent-to-values ent))))))
 130          #+sb-thread
 131          (sb-thread::with-system-mutex (**getprotoby-lock**)
 132            (get-it))
 133          #-sb-thread
 134          (get-it))
 135      :error
 136        (error 'unknown-protocol :name name))))
 137
 138 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
 139 ;;; bits-of-sockaddr
 140
 141 (defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address)))
 142   (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
 143     (when (and host port)
 144       (setf host (coerce host '(simple-array (unsigned-byte 8) (4))))
 145       ;; port and host are represented in C as "network-endian" unsigned
 146       ;; integers of various lengths.  This is stupid.  The value of the
 147       ;; integer doesn't matter (and will change depending on your
 148       ;; machine's endianness); what the bind(2) call is interested in
 149       ;; is the pattern of bytes within that integer.
 150
 151       ;; We have no truck with such dreadful type punning.  Octets to
 152       ;; octets, dust to dust.
 153
 154       (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
 155       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0) (ldb (byte 8 8) port))
 156       (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1) (ldb (byte 8 0) port))
 157
 158       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 0) (elt host 0))
 159       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 1) (elt host 1))
 160       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 2) (elt host 2))
 161       (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 3) (elt host 3)))
 162     sockaddr))
 163
 164 (defmethod free-sockaddr-for ((socket inet-socket) sockaddr)
 165   (sockint::free-sockaddr-in sockaddr))
 166
 167 (defmethod size-of-sockaddr ((socket inet-socket))
 168   sockint::size-of-sockaddr-in)
 169
 170 (defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
 171   "Returns address and port of SOCKADDR as multiple values"
 172   (values
 173    (coerce (loop for i from 0 below 4
 174                  collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i))
 175            '(vector (unsigned-byte 8) 4))
 176    (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
 177       (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1))))
 178
 179 (defun make-inet-socket (type protocol)
 180   "Make an INET socket.  Deprecated in favour of make-instance"
 181   (make-instance 'inet-socket :type type :protocol protocol))