net.sockets/address.lisp

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