src/sockets/address.lisp

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