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