net.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-2008, 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 (setf (documentation 'abstract-address-p 'function)
  50       "Return T if ADDRESS is a LOCAL-ADDRESS that lives in the abstract namespace.")
  51
  52 (defmethod make-load-form ((address inet-address) &optional env)
  53   (declare (ignore env))
  54   `(make-instance ,(class-of address)
  55                   :name ,(address-name address)))
  56
  57 (defmethod make-load-form ((address local-address) &optional env)
  58   (declare (ignore env))
  59   `(make-instance ,(class-of address)
  60                   :name ,(address-name address)
  61                   :abstract ,(abstract-address-p address)))
  62
  63 ;;;; Conversion functions for SOCKADDR_* structs
  64
  65 (defun sockaddr-in->sockaddr (sin)
  66   (with-foreign-slots ((addr port) sin sockaddr-in)
  67     (values (make-instance 'ipv4-address
  68                            :name (integer-to-vector (ntohl addr)))
  69             (ntohs port))))
  70
  71 (defun sockaddr-in6->sockaddr (sin6)
  72   (with-foreign-slots ((addr port) sin6 sockaddr-in6)
  73     (values (make-instance 'ipv6-address
  74                            :name (in6-addr-to-ipv6-array addr))
  75             (ntohs port))))
  76
  77 (defun sockaddr-un->sockaddr (sun)
  78   (with-foreign-slots ((path) sun sockaddr-un)
  79     (let ((name (make-string (1- unix-path-max)))
  80           (abstract nil))
  81       (cond ((zerop (mem-aref path :uint8 0))
  82              ;; abstract address
  83              (setf abstract t)
  84              (loop :for sindex :from 0 :below (1- unix-path-max)
  85                    :for pindex :from 1 :below unix-path-max
  86                    :do (setf (schar name sindex)
  87                              (code-char (mem-aref path :uint8 pindex)))))
  88             (t
  89              ;; address is in the filesystem
  90              (setf name (foreign-string-to-lisp path))))
  91       (make-instance 'local-address
  92                      :name name
  93                      :abstract abstract))))
  94
  95 (defun sockaddr-storage->sockaddr (ss)
  96   (with-foreign-slots ((family) ss sockaddr-storage)
  97     (switch (family :test #'=)
  98       (af-inet (sockaddr-in->sockaddr ss))
  99       (af-inet6 (sockaddr-in6->sockaddr ss))
 100       (af-local (sockaddr-un->sockaddr ss)))))
 101
 102 (defun sockaddr->sockaddr-storage (ss sockaddr &optional (port 0))
 103   (etypecase sockaddr
 104     (ipv4-address (make-sockaddr-in ss (address-name sockaddr) port))
 105     (ipv6-address (make-sockaddr-in6 ss (address-name sockaddr) port))
 106     (local-address (make-sockaddr-un ss (address-name sockaddr)))))
 107
 108 (defun sockaddr-size (ss)
 109   (with-foreign-slots ((family) ss sockaddr-storage)
 110     (switch (family :test #'=)
 111       (af-inet  size-of-sockaddr-in)
 112       (af-inet6 size-of-sockaddr-in6)
 113       (af-local size-of-sockaddr-un))))
 114
 115 ;;;; Conversion functions
 116
 117 (defun integer-to-dotted (integer)
 118   "Convert a 32-bit unsigned integer to a dotted string."
 119   (check-type integer ub32 "an '(unsigned-byte 32)")
 120   (format nil "~A.~A.~A.~A"
 121           (ldb (byte 8 24) integer)
 122           (ldb (byte 8 16) integer)
 123           (ldb (byte 8 8) integer)
 124           (ldb (byte 8 0) integer)))
 125
 126 (defun dotted-to-vector (address)
 127   "Convert a dotted IPv4 address to a (simple-array (unsigned-byte 8) 4)."
 128   (check-type address string "a string")
 129   (let ((addr (make-array 4 :element-type 'ub8 :initial-element 0))
 130         (split (split-sequence #\. address :count 5)))
 131     (flet ((set-array-value (index str)
 132              (setf (aref addr index)
 133                    (ensure-number str :type 'ub8))))
 134       (let ((len (length split)))
 135         (unless (<= 1 len 4)
 136           (error 'parse-error))
 137         (set-array-value 3 (nth (1- len) split))
 138         (loop :for n :in split
 139               :for index :below (1- len)
 140               :do (set-array-value index n))))
 141     (values addr)))
 142
 143 (defun dotted-to-integer (address)
 144   "Convert a dotted IPv4 address to a 32-bit unsigned integer."
 145   (vector-to-integer (dotted-to-vector address)))
 146
 147 (defun vector-to-dotted (vector)
 148   "Convert an 4-element vector to a dotted string."
 149   (coercef vector 'ipv4-array)
 150   (let ((*print-pretty* nil))
 151     (with-output-to-string (s)
 152       (princ (aref vector 0) s) (princ #\. s)
 153       (princ (aref vector 1) s) (princ #\. s)
 154       (princ (aref vector 2) s) (princ #\. s)
 155       (princ (aref vector 3) s))))
 156
 157 ;;; TODO: add tests against inet_pton().  Optimize if necessary.
 158 ;;; <http://java.sun.com/javase/6/docs/api/java/net/Inet6Address.html#format>
 159 (defun colon-separated-to-vector (string)
 160   "Convert a colon-separated IPv6 address to a (simple-array ub16 8)."
 161   (check-type string string "a string")
 162   (when (< (length string) 2)
 163     (error 'parse-error))
 164   (flet ((handle-trailing-and-leading-colons (string)
 165            (let ((start 0)
 166                  (end (length string))
 167                  (start-i 0)
 168                  (trailing-colon-p nil)
 169                  (tokens-from-leading-or-trailing-zeros 0))
 170              (when (char= #\: (char string 0))
 171                (incf start)
 172                (unless (char= #\: (char string 1))
 173                  (setq start-i 1)
 174                  (setq tokens-from-leading-or-trailing-zeros 1)))
 175              (when (char= #\: (char string (- end 1)))
 176                (setq trailing-colon-p t)
 177                (unless (char= #\: (char string (- end 2)))
 178                  (incf tokens-from-leading-or-trailing-zeros))
 179                (decf end))
 180              (values start end start-i trailing-colon-p
 181                      tokens-from-leading-or-trailing-zeros)))
 182          (emptyp (string)
 183            (= 0 (length string)))
 184          ;; we need to use this instead of dotted-to-vector because
 185          ;; abbreviated IPv4 addresses are invalid in this context.
 186          (ipv4-string-to-ub16-list (string)
 187            (let ((tokens (split-sequence #\. string)))
 188              (when (= (length tokens) 4)
 189                (let ((ipv4 (map 'vector
 190                                 (lambda (string)
 191                                   (let ((x (ignore-errors
 192                                              (parse-integer string))))
 193                                     (if (or (null x) (not (<= 0 x #xff)))
 194                                         (error 'parse-error)
 195                                         x)))
 196                                 tokens)))
 197                  (list (dpb (aref ipv4 0) (byte 8 8) (aref ipv4 1))
 198                        (dpb (aref ipv4 2) (byte 8 8) (aref ipv4 3)))))))
 199          (parse-hex-ub16 (string)
 200            (ensure-number string :type 'ub16 :radix 16)))
 201     (multiple-value-bind (start end start-i trailing-colon-p extra-tokens)
 202         (handle-trailing-and-leading-colons string)
 203       (let* ((vector (make-array 8 :element-type 'ub16 :initial-element 0))
 204              (tokens (split-sequence #\: string :start start :end end))
 205              (empty-tokens (count-if #'emptyp tokens))
 206              (token-count (+ (length tokens) extra-tokens)))
 207         (unless trailing-colon-p
 208           (let ((ipv4 (ipv4-string-to-ub16-list (lastcar tokens))))
 209             (when ipv4
 210               (incf token-count)
 211               (setq tokens (nconc (butlast tokens) ipv4)))))
 212         (when (or (> token-count 8) (> empty-tokens 1)
 213                   (and (zerop empty-tokens) (/= token-count 8)))
 214           (error 'parse-error))
 215         (loop for i from start-i and token in tokens do
 216               (cond
 217                 ((integerp token) (setf (aref vector i) token))
 218                 ((emptyp token) (incf i (- 8 token-count)))
 219                 (t (setf (aref vector i) (parse-hex-ub16 token)))))
 220         vector))))
 221
 222 (defun ipv4-on-ipv6-mapped-vector-p (vector)
 223   (and (dotimes (i 5 t)
 224          (when (plusp (aref vector i))
 225            (return nil)))
 226        (= (aref vector 5) #xffff)))
 227
 228 (defun princ-ipv4-on-ipv6-mapped-address (vector s)
 229   (princ "::ffff:" s)
 230   (let ((*print-base* 10) (*print-pretty* nil))
 231     (princ (ldb (byte 8 8) (aref vector 6)) s) (princ #\. s)
 232     (princ (ldb (byte 8 0) (aref vector 6)) s) (princ #\. s)
 233     (princ (ldb (byte 8 8) (aref vector 7)) s) (princ #\. s)
 234     (princ (ldb (byte 8 0) (aref vector 7)) s)))
 235
 236 (defun vector-to-colon-separated (vector &optional (case :downcase))
 237   "Convert an 8-element vector to a colon-separated IPv6
 238 address. CASE may be :DOWNCASE or :UPCASE."
 239   (coercef vector 'ipv6-array)
 240   (check-type case (member :upcase :downcase) "either :UPCASE or :DOWNCASE")
 241   (let ((s (make-string-output-stream)))
 242     (flet ((find-zeros ()
 243              (let ((start (position 0 vector :start 1 :end 7)))
 244                (when start
 245                  (values start
 246                          (position-if #'plusp vector :start start :end 7)))))
 247            (princ-subvec (start end)
 248              (loop :for i :from start :below end
 249                    :do (princ (aref vector i) s) (princ #\: s))))
 250       (cond
 251         ((ipv4-on-ipv6-mapped-vector-p vector)
 252          (princ-ipv4-on-ipv6-mapped-address vector s))
 253         (t
 254          (let ((*print-base* 16) (*print-pretty* nil))
 255            (when (plusp (aref vector 0)) (princ (aref vector 0) s))
 256            (princ #\: s)
 257            (multiple-value-bind (start end) (find-zeros)
 258              (cond (start (princ-subvec 1 start)
 259                           (princ #\: s)
 260                           (when end (princ-subvec end 7)))
 261                    (t (princ-subvec 1 7))))
 262            (when (plusp (aref vector 7)) (princ (aref vector 7) s))))))
 263     (let ((str (get-output-stream-string s)))
 264       (ecase case
 265         (:downcase (nstring-downcase str))
 266         (:upcase (nstring-upcase str))))))
 267
 268 (defmacro ignore-parse-errors (&body body)
 269   ;; return first value only
 270   `(values (ignore-some-conditions (parse-error) ,@body)))
 271
 272 (defun string-address-to-vector (address)
 273   "Convert a string address (dotted or colon-separated) to a vector address.
 274 If the string is not a valid address, return NIL."
 275   (or (ignore-parse-errors (dotted-to-vector address))
 276       (ignore-parse-errors (colon-separated-to-vector address))))
 277
 278 (defun address-to-vector (address)
 279   "Convert any representation of an internet address to a vector.
 280 Allowed inputs are: unsigned 32-bit integers, strings, vectors
 281 and INET-ADDRESS objects.  If the address is valid, two values
 282 are returned: the vector and the address type (:IPV4 or IPV6),
 283 otherwise NIL is returned."
 284   (let (vector addr-type)
 285     (typecase address
 286       (number (and (ignore-parse-errors
 287                      (setf vector (integer-to-vector address)))
 288                    (setf addr-type :ipv4)))
 289       (string (cond
 290                 ((ignore-parse-errors (setf vector (dotted-to-vector address)))
 291                  (setf addr-type :ipv4))
 292                 ((ignore-parse-errors
 293                    (setf vector (colon-separated-to-vector address)))
 294                  (setf addr-type :ipv6))))
 295       ((vector * 4) (and (ignore-parse-errors
 296                            (setf vector (coerce address 'ipv4-array)))
 297                          (setf addr-type :ipv4)))
 298       ((vector * 8) (and (ignore-parse-errors
 299                            (setf vector (coerce address 'ipv6-array)))
 300                          (setf addr-type :ipv6)))
 301       (ipv4-address (setf vector (copy-seq (address-name address))
 302                           addr-type :ipv4))
 303       (ipv6-address (setf vector (copy-seq (address-name address))
 304                           addr-type :ipv6)))
 305     (when vector
 306       (values vector addr-type))))
 307
 308 (defun ensure-address (address &key (family :internet) (errorp t))
 309   "If FAMILY is :LOCAL, a LOCAL-ADDRESS is instantiated with
 310 ADDRESS as its NAME slot. If FAMILY is :INTERNET, an appropriate
 311 subtype of INET-ADDRESS is instantiated after guessing the
 312 address type through ADDRESS-TO-VECTOR. If the address is invalid
 313 and ERRORP is not NIL, then a CL:PARSE-ERROR is signalled,
 314 otherwise NIL is returned.
 315
 316 When ADDRESS is already an instance of the ADDRESS class, a check
 317 is made to see if it matches the FAMILY argument and it is
 318 returned unmodified."
 319   (ecase family
 320     (:internet
 321      (typecase address
 322        (address (if errorp
 323                     (check-type address inet-address "an INET address")
 324                     (unless (typep address 'inet-address)
 325                       (return-from ensure-address)))
 326                 address)
 327        (t (let ((vector (address-to-vector address)))
 328             (cond
 329               (vector (make-address vector))
 330               (errorp (error 'parse-error)))))))
 331     (:local
 332      (etypecase address
 333        (string (make-instance 'local-address :name address))
 334        (address (if errorp
 335                     (check-type address local-address "a local address")
 336                     (unless (typep address 'local-address)
 337                       (return-from ensure-address)))
 338                 address)))))
 339
 340 ;;;; Print Methods
 341
 342 (defgeneric address-to-string (address)
 343   (:documentation "Returns a textual presentation of ADDRESS."))
 344
 345 (defmethod address-to-string ((address ipv4-address))
 346   (vector-to-dotted (address-name address)))
 347
 348 (defmethod address-to-string ((address ipv6-address))
 349   (vector-to-colon-separated (address-name address)))
 350
 351 (defmethod address-to-string ((address local-address))
 352   (if (abstract-address-p address)
 353       "<unknown socket>"
 354       (address-name address)))
 355
 356 (defmethod print-object ((address ipv4-address) stream)
 357   (format stream "@~A" (address-to-string address)))
 358
 359 (defmethod print-object ((address ipv6-address) stream)
 360   (format stream "@~A" (address-to-string address)))
 361
 362 (defmethod print-object ((address local-address) stream)
 363   (print-unreadable-object (address stream :type nil :identity nil)
 364     (format stream "Unix socket address: ~A. Abstract: ~:[no~;yes~]"
 365             (address-to-string address) (abstract-address-p address))))
 366
 367 ;;;; Reader Macro
 368
 369 (defun read-literal-ip-address (stream &optional c n)
 370   (declare (ignore c n))
 371   (loop :with sstr := (make-string-output-stream)
 372         :for char := (read-char stream nil nil)
 373         :while char
 374         :do (cond ((or (digit-char-p char 16)
 375                        (member char '(#\. #\:) :test #'char=))
 376                    (write-char char sstr))
 377                   (t
 378                    (unread-char char stream)
 379                    (loop-finish)))
 380         :finally (return (or (ensure-address (get-output-stream-string sstr)
 381                                              :errorp nil)
 382                              (error 'reader-error :stream stream)))))
 383
 384 (define-syntax ip-address
 385   (set-macro-character #\@ 'read-literal-ip-address t))
 386
 387 ;;;; Equality Methods
 388
 389 (defun vector-equal (v1 v2)
 390   (and (= (length v1) (length v2))
 391        (every #'eql v1 v2)))
 392
 393 (defgeneric address= (addr1 addr2)
 394   (:documentation "Returns T if both arguments are the same socket address."))
 395
 396 (defmethod address= ((addr1 inet-address) (addr2 inet-address))
 397   (vector-equal (address-name addr1) (address-name addr2)))
 398
 399 (defmethod address= ((addr1 local-address) (addr2 local-address))
 400   (equal (address-name addr1) (address-name addr2)))
 401
 402 (defun address-equal-p (addr1 addr2 &optional (family :internet))
 403   "Returns T if both arguments are designators for the same socket address."
 404   (address= (ensure-address addr1 :family family)
 405             (ensure-address addr2 :family family)))
 406
 407 ;;;; Copy Methods
 408
 409 (defgeneric copy-address (address)
 410   (:documentation
 411    "Returns a copy of ADDRESS which is ADDRESS= to the original."))
 412
 413 (defmethod copy-address ((addr ipv4-address))
 414   (make-instance 'ipv4-address :name (copy-seq (address-name addr))))
 415
 416 (defmethod copy-address ((addr ipv6-address))
 417   (make-instance 'ipv6-address :name (copy-seq (address-name addr))))
 418
 419 (defmethod copy-address ((addr local-address))
 420   (make-instance 'local-address
 421                  :name (copy-seq (address-name addr))
 422                  :abstract (abstract-address-p addr)))
 423
 424 (defun map-ipv4-address-to-ipv6 (address)
 425   "Returns an IPv6 address by mapping ADDRESS onto it."
 426   (make-instance 'ipv6-address
 427                  :name (map-ipv4-vector-to-ipv6 (address-name address))))
 428
 429 (defun map-ipv6-address-to-ipv4 (address)
 430   "Extracts the IPv4 part of an IPv6-mapped IPv4 address.
 431 Signals an error if ADDRESS is not an IPv6-mapped IPv4 address."
 432   (assert (ipv6-ipv4-mapped-p address) (address)
 433           "Not an IPv6-mapped IPv4 address: ~A" address)
 434   (make-instance 'ipv4-address
 435                  :name (map-ipv6-vector-to-ipv4 (address-name address))))
 436
 437 ;;;; Constructor
 438
 439 (defun make-address (name)
 440   "Constructs an ADDRESS object.  NAME should be of type
 441 IPV4-ARRAY, IPV6-ARRAY or STRING in which case an instance of
 442 IPV4-ADDRESS, IPV6-ADDRESS or LOCAL-ADDRESS, respectively, will
 443 be created.  Otherwise, a TYPE-ERROR is signalled.  See also
 444 ENSURE-ADDRESS."
 445   (cond
 446     ((ignore-errors (coercef name 'ipv4-array))
 447      (make-instance 'ipv4-address :name name))
 448     ((ignore-errors (coercef name 'ipv6-array))
 449      (make-instance 'ipv6-address :name name))
 450     ((stringp name) (make-instance 'local-address :name name))
 451     (t (error 'type-error :datum name
 452               :expected-type '(or string ipv4-array ipv6-array)))))