sockets/address.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; address.lisp --- IP address classes.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 ;;;; Class Definitions
  27
  28 (defclass address ()
  29   ((name :initarg :name :reader address-name :type vector))
  30   (:documentation "Base class for all socket address classes."))
  31
  32 (defclass inet-address (address) ()
  33   (:documentation "Base class for IPv4 and IPv6 addresses."))
  34
  35 (defclass ipv4-address (inet-address) ()
  36   (:documentation "IPv4 address.  Its low-level representation
  37 can be accessed as vector of type IPV4-ARRAY through the
  38 ADDRESS-NAME reader."))
  39
  40 (defclass ipv6-address (inet-address) ()
  41   (:documentation "IPv6 address.  Its low-level representation
  42 can be accessed as vector of type IPV6-ARRAY through the
  43 ADDRESS-NAME reader."))
  44
  45 (defclass local-address (address)
  46   ((abstract :initform nil :initarg :abstract
  47              :reader abstract-address-p :type boolean))
  48   (:documentation "UNIX socket address."))
  49
  50 ;;;; Conversion functions
  51
  52 (defun integer-to-dotted (integer)
  53   "Convert a 32-bit unsigned integer to a dotted string."
  54   (check-type integer ub32)
  55   (format nil "~A.~A.~A.~A"
  56           (ldb (byte 8 24) integer)
  57           (ldb (byte 8 16) integer)
  58           (ldb (byte 8 8) integer)
  59           (ldb (byte 8 0) integer)))
  60
  61 (defun dotted-to-vector (address)
  62   "Convert a dotted IPv4 address to a (simple-array (unsigned-byte 8) 4)."
  63   (check-type address string)
  64   (let ((addr (make-array 4 :element-type 'ub8 :initial-element 0))
  65         (split (split-sequence #\. address :count 5)))
  66     (flet ((set-array-value (index str)
  67              (setf (aref addr index)
  68                    (or (parse-number-or-nil str :ub8)
  69                        (error 'parse-error)))))
  70       (let ((len (length split)))
  71         (unless (<= 1 len 4)
  72           (error 'parse-error))
  73         (set-array-value 3 (nth (1- len) split))
  74         (loop :for n :in split
  75               :for index :below (1- len)
  76               :do (set-array-value index n))))
  77     (values addr)))
  78
  79 (defun dotted-to-integer (address)
  80   "Convert a dotted IPv4 address to a 32-bit unsigned integer."
  81   (vector-to-integer (dotted-to-vector address)))
  82
  83 (defun vector-to-dotted (vector)
  84   "Convert an 4-element vector to a dotted string."
  85   (coercef vector 'ipv4-array)
  86   (let ((*print-pretty* nil))
  87     (with-output-to-string (s)
  88       (princ (aref vector 0) s) (princ #\. s)
  89       (princ (aref vector 1) s) (princ #\. s)
  90       (princ (aref vector 2) s) (princ #\. s)
  91       (princ (aref vector 3) s))))
  92
  93 #+windows
  94 (defun %ipv6-string-to-vector (string)
  95   (with-foreign-object (in6-sockaddr 'sockaddr-in6)
  96     (bzero in6-sockaddr size-of-sockaddr-in6)
  97     (with-foreign-object (length :int)
  98       (setf (mem-ref length :int) size-of-sockaddr-in6)
  99       (handler-case
 100           (wsa-string-to-address string af-inet6 (null-pointer) in6-sockaddr
 101                                  length)
 102         (socket-error () (error 'parse-error)))
 103       (in6-addr-to-ipv6-array
 104        (foreign-slot-value in6-sockaddr 'sockaddr-in6 'addr)))))
 105
 106 #+windows
 107 (handler-case (%ipv6-string-to-vector "::")
 108   (parse-error () (pushnew 'ipv6-disabled *features*)))
 109
 110 #-windows
 111 (defun %ipv6-string-to-vector (string)
 112   (with-foreign-object (in6-addr :uint16 8)
 113     (bzero in6-addr 16)
 114     (handler-case (inet-pton af-inet6 string-pointer in6-addr)
 115       (posix-error () (error 'parse-error)))
 116     (in6-addr-to-ipv6-array in6-addr)))
 117
 118 (defun colon-separated-to-vector (string)
 119   "Convert a colon-separated IPv6 address to
 120 a (simple-array (unsigned-byte 16) 8)."
 121   (check-type string string)
 122   (%ipv6-string-to-vector string))
 123
 124 (defun ipv4-on-ipv6-mapped-vector-p (vector)
 125   (and (dotimes (i 5 t)
 126          (when (plusp (aref vector i))
 127            (return nil)))
 128        (= (aref vector 5) #xffff)))
 129
 130 (defun vector-to-colon-separated (vector &optional (case :downcase))
 131   "Convert an 8-element vector to a colon-separated IPv6
 132 address. CASE may be :DOWNCASE or :UPCASE."
 133   (coercef vector 'ipv6-array)
 134   (check-type case (member :upcase :downcase))
 135   (labels ((find-zeros ()
 136              (loop :for i :from 0 :upto 6
 137                    :if (and (zerop (aref vector i))
 138                             (zerop (aref vector (1+ i))))
 139                    :do (return
 140                          (values i (or (position-if #'plusp vector :start (1+ i))
 141                                        8)))))
 142            (princ-subvec (start end s)
 143              (loop :for i :from start :below end
 144                    :do (princ #\: s) (princ (aref vector i) s))))
 145     (let ((s (make-string-output-stream)))
 146       (cond
 147         ((ipv4-on-ipv6-mapped-vector-p vector)
 148          (princ "::ffff:" s)
 149          (let ((*print-base* 10))
 150            (princ (ldb (byte 8 8) (aref vector 6)) s) (princ #\. s)
 151            (princ (ldb (byte 8 0) (aref vector 6)) s) (princ #\. s)
 152            (princ (ldb (byte 8 8) (aref vector 7)) s) (princ #\. s)
 153            (princ (ldb (byte 8 0) (aref vector 7)) s)))
 154         (t
 155          (let ((*print-base* 16))
 156            (multiple-value-bind (start end) (find-zeros)
 157              (cond (start
 158                     (when (plusp start)
 159                       (princ (aref vector 0) s)
 160                       (princ-subvec 1 start s))
 161                     (princ #\: s)
 162                     (if (< end 8)
 163                         (princ-subvec end 8 s)
 164                         (princ #\: s)))
 165                    (t (princ (aref vector 0) s)
 166                       (princ-subvec 1 8 s)))))))
 167       (let ((str (get-output-stream-string s)))
 168         (ecase case
 169           (:downcase (nstring-downcase str))
 170           (:upcase (nstring-upcase str)))))))
 171
 172 (defmacro ignore-parse-errors (&body body)
 173   ;; return first value only
 174   `(values (alexandria:ignore-some-conditions (parse-error) ,@body)))
 175
 176 (defun string-address-to-vector (address)
 177   "Convert a string address (dotted or colon-separated) to a vector address.
 178 If the string is not a valid address, return NIL."
 179   (or (ignore-parse-errors (dotted-to-vector address))
 180       (ignore-parse-errors (colon-separated-to-vector address))))
 181
 182 (defun address-to-vector (address)
 183   "Convert any representation of an internet address to a vector.
 184 Allowed inputs are: unsigned 32-bit integers, strings, vectors
 185 and INET-ADDRESS objects.  If the address is valid, two values
 186 are returned: the vector and the address type (:IPV4 or IPV6),
 187 otherwise NIL is returned."
 188   (let (vector
 189         addr-type)
 190     (typecase address
 191       (number (and (ignore-parse-errors
 192                     (setf vector (integer-to-vector address)))
 193                    (setf addr-type :ipv4)))
 194       (string (cond
 195                 ((ignore-parse-errors (setf vector (dotted-to-vector address)))
 196                  (setf addr-type :ipv4))
 197                 ((ignore-parse-errors
 198                    (setf vector (colon-separated-to-vector address)))
 199                  (setf addr-type :ipv6))))
 200       ((vector * 4) (and (ignore-parse-errors
 201                            (setf vector (coerce address 'ipv4-array)))
 202                          (setf addr-type :ipv4)))
 203       ((vector * 8) (and (ignore-parse-errors
 204                            (setf vector (coerce address 'ipv6-array)))
 205                          (setf addr-type :ipv6)))
 206       (ipv4-address (setf vector (address-name address)
 207                           addr-type :ipv4))
 208       (ipv6-address (setf vector (address-name address)
 209                           addr-type :ipv6)))
 210     (when vector
 211       (values vector addr-type))))
 212
 213 (defun ensure-address (address &optional (family :internet))
 214   "If FAMILY is :LOCAL, a LOCAL-ADDRESS is instantiated with
 215 ADDRESS as its NAME slot. If FAMILY is :INTERNET, an appropriate
 216 subtype of INET-ADDRESS is instantiated after guessing the
 217 address type through ADDRESS-TO-VECTOR. If the address is not
 218 valid, a CL:PARSE-ERROR is signalled.
 219
 220 When ADDRESS is already an instance of the ADDRESS class, a check
 221 is made to see if it matches the FAMILY argument and it is
 222 returned unmodified."
 223   (ecase family
 224     (:internet
 225      (typecase address
 226        (address (check-type address inet-address) address)
 227        (t (make-address (or (address-to-vector address)
 228                             (error 'parse-error))))))
 229     (:local
 230      (etypecase address
 231        (string (make-instance 'local-address :name address))
 232        (address (check-type address local-address) address)))))
 233
 234 ;;;; Print Methods
 235
 236 (defgeneric address-to-string (address)
 237   (:documentation "Returns a textual presentation of ADDRESS."))
 238
 239 (defmethod address-to-string ((address ipv4-address))
 240   (vector-to-dotted (address-name address)))
 241
 242 (defmethod address-to-string ((address ipv6-address))
 243   (vector-to-colon-separated (address-name address)))
 244
 245 (defmethod address-to-string ((address local-address))
 246   (if (abstract-address-p address)
 247       "<unknown socket>"
 248       (address-name address)))
 249
 250 (defmethod print-object ((address ipv4-address) stream)
 251   (print-unreadable-object (address stream :type nil :identity nil)
 252     (format stream "IPv4 address: ~A" (address-to-string address))))
 253
 254 (defmethod print-object ((address ipv6-address) stream)
 255   (print-unreadable-object (address stream :type nil :identity nil)
 256     (format stream "IPv6 address: ~A" (address-to-string address))))
 257
 258 (defmethod print-object ((address local-address) stream)
 259   (print-unreadable-object (address stream :type nil :identity nil)
 260     (format stream "Unix socket address: ~A. Abstract: ~:[no~;yes~]"
 261             (address-to-string address) (abstract-address-p address))))
 262
 263 ;;;; Equality Methods
 264
 265 (defun vector-equal (v1 v2)
 266   (and (= (length v1) (length v2))
 267        (every #'eql v1 v2)))
 268
 269 (defgeneric address= (addr1 addr2)
 270   (:documentation "Returns T if both arguments are the same socket address."))
 271
 272 (defmethod address= ((addr1 inet-address) (addr2 inet-address))
 273   (vector-equal (address-name addr1) (address-name addr2)))
 274
 275 (defmethod address= ((addr1 local-address) (addr2 local-address))
 276   (equal (address-name addr1) (address-name addr2)))
 277
 278 (defun address-equal-p (addr1 addr2 &optional (family :internet))
 279   "Returns T if both arguments are designators for the same socket address."
 280   (address= (ensure-address addr1 family)
 281             (ensure-address addr2 family)))
 282
 283 ;;;; Copy Methods
 284
 285 (defgeneric copy-address (address)
 286   (:documentation
 287    "Returns a copy of ADDRESS which is ADDRESS= to the original."))
 288
 289 (defmethod copy-address ((addr ipv4-address))
 290   (make-instance 'ipv4-address :name (copy-seq (address-name addr))))
 291
 292 (defmethod copy-address ((addr ipv6-address))
 293   (make-instance 'ipv6-address :name (copy-seq (address-name addr))))
 294
 295 (defmethod copy-address ((addr local-address))
 296   (make-instance 'local-address
 297                  :name (copy-seq (address-name addr))
 298                  :abstract (abstract-address-p addr)))
 299
 300 ;;; Returns an IPv6 address by mapping ADDR onto it.
 301 (defun map-ipv4-address-to-ipv6 (address)
 302   (make-instance 'ipv6-address
 303                  :name (map-ipv4-vector-to-ipv6 (address-name address))))
 304
 305 ;;;; Constructor
 306
 307 (defun make-address (name)
 308   "Constructs an ADDRESS object.  NAME should be of type
 309 IPV4-ARRAY, IPV6-ARRAY or STRING in which case an instance of
 310 IPV4-ADDRESS, IPV6-ADDRESS or LOCAL-ADDRESS, respectively, will
 311 be created.  Otherwise, a TYPE-ERROR is signalled.  See also
 312 ENSURE-ADDRESS."
 313   (cond
 314     ((ignore-errors (coercef name 'ipv4-array))
 315      (make-instance 'ipv4-address :name name))
 316     ((ignore-errors (coercef name 'ipv6-array))
 317      (make-instance 'ipv6-address :name name))
 318     ((stringp name) (make-instance 'local-address :name name))
 319     (t (error 'type-error :datum name
 320               :expected-type '(or string ipv4-array ipv6-array)))))