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