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