contrib/sb-bsd-sockets/inet4.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 over IPv4 sockets.
   9
  10 Examples:
  11
  12  (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)
  13
  14  (make-instance 'sb-bsd-sockets:inet-socket :type :datagram :protocol :udp)
  15 ")))
  16
  17 (defparameter *inet-address-any* (vector 0 0 0 0))
  18
  19 (defun address-numbers/v4 (address)
  20   (coerce address 'list))
  21
  22 (defun endpoint-string/v4 (address port)
  23   (format nil "~{~A~^.~}:~A" (address-numbers/v4 address) port))
  24
  25 (defmethod socket-namestring ((socket inet-socket))
  26   (ignore-errors
  27     (multiple-value-bind (address port) (socket-name socket)
  28       (endpoint-string/v4 address port))))
  29
  30 (defmethod socket-peerstring ((socket inet-socket))
  31   (ignore-errors
  32     (multiple-value-bind (address port) (socket-peername socket)
  33       (endpoint-string/v4 address port))))
  34
  35 ;;; binding a socket to an address and port.  Doubt that anyone's
  36 ;;; actually using this much, to be honest.
  37
  38 (defun make-inet-address (dotted-quads)
  39   "Return a vector of octets given a string DOTTED-QUADS in the format
  40 \"127.0.0.1\". Signals an error if the string is malformed."
  41   (declare (type string dotted-quads))
  42   (labels ((oops ()
  43              (error "~S is not a string designating an IP address."
  44                     dotted-quads))
  45            (check (x)
  46              (if (typep x '(unsigned-byte 8))
  47                  x
  48                  (oops))))
  49     (let* ((s1 (position #\. dotted-quads))
  50            (s2 (if s1 (position #\. dotted-quads :start (1+ s1)) (oops)))
  51            (s3 (if s2 (position #\. dotted-quads :start (1+ s2)) (oops)))
  52            (u0 (parse-integer dotted-quads :end s1))
  53            (u1 (parse-integer dotted-quads :start (1+ s1) :end s2))
  54            (u2 (parse-integer dotted-quads :start (1+ s2) :end s3)))
  55       (multiple-value-bind (u3 end) (parse-integer dotted-quads :start (1+ s3) :junk-allowed t)
  56         (unless (= end (length dotted-quads))
  57           (oops))
  58         (let ((vector (make-array 4 :element-type '(unsigned-byte 8))))
  59           (setf (aref vector 0) (check u0)
  60                 (aref vector 1) (check u1)
  61                 (aref vector 2) (check u2)
  62                 (aref vector 3) (check u3))
  63           vector)))))
  64
  65 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
  66 ;;; bits-of-sockaddr
  67
  68 (defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address)
  69   (check-type address (or null (cons sequence (cons (unsigned-byte 16)))))
  70   (let ((host (first address))
  71         (port (second address))
  72         (sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
  73     (when (and host port)
  74       (assert (= (length host) 4))
  75       (let ((in-port (sockint::sockaddr-in-port sockaddr))
  76             (in-addr (sockint::sockaddr-in-addr sockaddr)))
  77         (declare (fixnum port))
  78         ;; port and host are represented in C as "network-endian" unsigned
  79         ;; integers of various lengths.  This is stupid.  The value of the
  80         ;; integer doesn't matter (and will change depending on your
  81         ;; machine's endianness); what the bind(2) call is interested in
  82         ;; is the pattern of bytes within that integer.
  83
  84         ;; We have no truck with such dreadful type punning.  Octets to
  85         ;; octets, dust to dust.
  86         (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
  87         (setf (sb-alien:deref in-port 0) (ldb (byte 8 8) port))
  88         (setf (sb-alien:deref in-port 1) (ldb (byte 8 0) port))
  89
  90         (setf (sb-alien:deref in-addr 0) (elt host 0))
  91         (setf (sb-alien:deref in-addr 1) (elt host 1))
  92         (setf (sb-alien:deref in-addr 2) (elt host 2))
  93         (setf (sb-alien:deref in-addr 3) (elt host 3))))
  94   sockaddr))
  95
  96 (defmethod free-sockaddr-for ((socket inet-socket) sockaddr)
  97   (sockint::free-sockaddr-in sockaddr))
  98
  99 (defmethod size-of-sockaddr ((socket inet-socket))
 100   sockint::size-of-sockaddr-in)
 101
 102 (defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
 103   "Returns address and port of SOCKADDR as multiple values"
 104   (declare (type (sb-alien:alien
 105                   (* (sb-alien:struct sb-bsd-sockets-internal::sockaddr-in)))
 106                  sockaddr))
 107   (let ((vector (make-array 4 :element-type '(unsigned-byte 8))))
 108     (loop for i below 4
 109           do (setf (aref vector i)
 110                    (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)))
 111     (values
 112      vector
 113      (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
 114         (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))))
 115
 116 (defun make-inet-socket (type protocol)
 117   "Make an INET socket."
 118   (make-instance 'inet-socket :type type :protocol protocol))
 119
 120 (declaim (sb-ext:deprecated
 121           :late ("SBCL" "1.2.15")
 122           (function make-inet-socket :replacement make-instance)))