sockets/address.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 ;;;;;;;;;;;;;;;;
  25 ;;;  ERRORS  ;;;
  26 ;;;;;;;;;;;;;;;;
  27
  28 (define-condition invalid-address ()
  29   ((address  :initarg :address  :initform nil :reader address)
  30    (addrtype :initarg :type     :initform nil :reader address-type))
  31   (:report (lambda (condition stream)
  32              (format stream "Invalid ~A address: ~A"
  33                      (address-type condition) (address condition))))
  34   (:documentation "Condition raised when an address designator is invalid."))
  35
  36 ;;;
  37 ;;; Conversion functions
  38 ;;;
  39
  40 ;; From CLOCC's PORT library
  41 (defun ipaddr-to-vector (ipaddr)
  42   (declare (type ub32 ipaddr))
  43   (vector (ldb (byte 8 24) ipaddr)
  44           (ldb (byte 8 16) ipaddr)
  45           (ldb (byte 8 8)  ipaddr)
  46           (ldb (byte 8 0)  ipaddr)))
  47
  48 (defun ipaddr-to-dotted (ipaddr)
  49   (declare (type ub32 ipaddr))
  50   (format nil "~A.~A.~A.~A"
  51           (ldb (byte 8 24) ipaddr)
  52           (ldb (byte 8 16) ipaddr)
  53           (ldb (byte 8 8)  ipaddr)
  54           (ldb (byte 8 0)  ipaddr)))
  55
  56 (defun dotted-to-vector (string &key (errorp t))
  57   (when (not (stringp string))
  58     (if errorp
  59         (error 'type-error :datum string
  60                :expected-type 'string)
  61         (return-from dotted-to-vector nil)))
  62
  63   (let ((addr (make-array 4 :element-type 'ub8))
  64         parsed)
  65     (multiple-value-bind (split len)
  66         (split-sequence #\. string :count 5)
  67       (tagbody
  68          ;; must have exactly 4 tokens
  69          (when (/= 4 (length split))
  70            (go :error))
  71          (loop
  72             :for element :in split
  73             :for index :below 4 :do
  74             (setf parsed (parse-number-or-nil element :ub8))
  75             (if parsed
  76                 (setf (aref addr index) parsed)
  77                 (go :error)))
  78          (return-from dotted-to-vector addr)
  79        :error (if errorp
  80                   (error 'invalid-address :address string :type :ipv4)
  81                   (return-from dotted-to-vector nil))))))
  82
  83 (defun dotted-to-ipaddr (string)
  84   (vector-to-ipaddr (dotted-to-vector string)))
  85
  86 (defun vector-to-dotted (vector)
  87   (setf vector (coerce vector '(simple-array ub8 (4))))
  88   (format nil "~A.~A.~A.~A"
  89           (aref vector 0)
  90           (aref vector 1)
  91           (aref vector 2)
  92           (aref vector 3)))
  93
  94 (defun colon-separated-to-vector (string &key (errorp t))
  95   (when (not (stringp string))
  96     (if errorp
  97         (error 'type-error :datum string
  98                :expected-type 'string)
  99         (return-from colon-separated-to-vector nil)))
 100
 101   (with-foreign-object (in6-addr :uint16 8)
 102     (with-foreign-string (string-pointer string)
 103       (et:bzero in6-addr 16)
 104       (handler-case
 105           (et:inet-pton et:af-inet6        ; address family
 106                         string-pointer     ; name
 107                         in6-addr)          ; pointer to struct in6_addr
 108         (unix-error (err)
 109           (declare (ignore err))
 110           (if errorp
 111               (error 'invalid-address :address string :type :ipv6)
 112               (return-from colon-separated-to-vector nil)))))
 113     (make-vector-u16-8-from-in6-addr in6-addr)))
 114
 115 (defun vector-to-colon-separated (vector &key (case :downcase) (errorp t))
 116   (handler-case
 117       (setf vector (coerce vector '(simple-array ub16 (8))))
 118     (type-error (err)
 119       (declare (ignore err))
 120       (if errorp
 121           (error 'type-error :datum vector
 122                  :expected-type '(simple-array (unsigned-byte 16) (8)))
 123           (return-from vector-to-colon-separated nil))))
 124
 125   (with-foreign-object (sin6 'et:sockaddr-in6)
 126     (with-foreign-pointer (namebuf et:inet6-addrstrlen bufsize)
 127       (make-sockaddr-in6 sin6 vector)
 128       (et:inet-ntop et:af-inet6                          ; address family
 129                     (foreign-slot-pointer
 130                       sin6 'et:sockaddr-in6 'et:addr)    ; pointer to struct in6_addr
 131                     namebuf                              ; destination buffer
 132                     bufsize)                             ; INET6_ADDRSTRLEN
 133       (return-from vector-to-colon-separated
 134         (let ((str (foreign-string-to-lisp namebuf bufsize)))
 135           (ecase case
 136             (:downcase str)
 137             (:upcase (nstring-upcase str))))))))
 138
 139 (defun string-address->vector (address)
 140   (or (dotted-to-vector address :errorp nil)
 141       (colon-separated-to-vector address :errorp nil)))
 142
 143 (defun vector-address-or-nil (address)
 144   (let (vector addr-type)
 145     (typecase address
 146       (string (cond
 147                 ((setf vector (dotted-to-vector address :errorp nil))
 148                  (setf addr-type :ipv4))
 149                 ((setf vector (colon-separated-to-vector address :errorp nil))
 150                  (setf addr-type :ipv6))))
 151       ((array * (4)) (cond ((setf vector (ignore-errors
 152                                            (coerce address '(simple-array ub8 (4)))))
 153                             (setf addr-type :ipv4))))
 154       ((array * (8)) (cond ((setf vector (ignore-errors
 155                                            (coerce address '(simple-array ub16 (8)))))
 156                             (setf addr-type :ipv6))))
 157       (ipv4addr (setf vector (name address)
 158                       addr-type :ipv4))
 159       (ipv6addr (setf vector (name address)
 160                       addr-type :ipv6)))
 161     (values vector addr-type)))
 162
 163
 164 ;;;
 165 ;;; Class definitions
 166 ;;;
 167
 168 (defclass sockaddr ()
 169   ((name :initarg :name :reader name :type vector))
 170   (:documentation "Base class for all socket address classes."))
 171
 172 (defclass inetaddr (sockaddr) ()
 173   (:documentation "IP addresses."))
 174
 175 (defclass ipv4addr (inetaddr) ()
 176   (:documentation "IPv4 address."))
 177
 178 (defclass ipv6addr (inetaddr) ()
 179   (:documentation "IPv6 address."))
 180
 181 (defclass localaddr (sockaddr)
 182   ((abstract :initform nil :initarg :abstract :reader abstract-p :type boolean))
 183   (:documentation "UNIX socket address."))
 184
 185
 186 ;;;
 187 ;;; Print methods
 188 ;;;
 189
 190 (defmethod print-object ((address ipv4addr) stream)
 191   (print-unreadable-object (address stream :type nil :identity nil)
 192     (with-slots (name) address
 193       (format stream "IPv4 address: ~A"
 194               (sockaddr->presentation address)))))
 195
 196 (defmethod print-object ((address ipv6addr) stream)
 197   (print-unreadable-object (address stream :type nil :identity nil)
 198     (with-slots (name) address
 199       (format stream "IPv6 address: ~A"
 200               (sockaddr->presentation address)))))
 201
 202 (defmethod print-object ((address localaddr) stream)
 203   (print-unreadable-object (address stream :type nil :identity nil)
 204     (with-slots (name abstract) address
 205       (format stream "Unix socket address: ~A. Abstract: ~:[no~;yes~]"
 206               (sockaddr->presentation address) abstract))))
 207
 208 (defgeneric sockaddr->presentation (addr)
 209   (:documentation "Returns a textual presentation of ADDR."))
 210
 211 (defmethod sockaddr->presentation ((addr ipv4addr))
 212   (vector-to-dotted (name addr)))
 213
 214 (defmethod sockaddr->presentation ((addr ipv6addr))
 215   (vector-to-colon-separated (name addr)))
 216
 217 (defmethod sockaddr->presentation ((addr localaddr))
 218   (if (abstract-p addr)
 219       "unknown socket"
 220       (name addr)))
 221
 222
 223 ;;;
 224 ;;; Equality methods
 225 ;;;
 226
 227 (defun vector-equal (v1 v2)
 228   (and (equal (length v1) (length v2))
 229        (every #'eql v1 v2)))
 230
 231 (defgeneric sockaddr= (addr1 addr2)
 232   (:documentation "Returns T if both arguments are the same socket address."))
 233
 234 (defmethod sockaddr= ((addr1 inetaddr) (addr2 inetaddr))
 235   (vector-equal (name addr1) (name addr2)))
 236
 237 (defmethod sockaddr= ((addr1 localaddr) (addr2 localaddr))
 238   (equal (name addr1) (name addr2)))
 239
 240
 241 ;;;
 242 ;;; Copy methods
 243 ;;;
 244
 245 (defgeneric copy-sockaddr (addr)
 246   (:documentation "Returns a copy of ADDR which is SOCKADDR= to the original."))
 247
 248 (defmethod copy-sockaddr ((addr ipv4addr))
 249   (make-instance 'ipv4addr
 250                  :name (copy-seq (name addr))))
 251
 252 (defmethod copy-sockaddr ((addr ipv6addr))
 253   (make-instance 'ipv6addr
 254                  :name (copy-seq (name addr))))
 255
 256 (defmethod copy-sockaddr ((addr localaddr))
 257   (make-instance 'localaddr
 258                  :name (copy-seq (name addr))
 259                  :abstract (abstract-p addr)))
 260
 261 (defgeneric map-ipv4-address->ipv6 (addr)
 262   (:documentation "Returns an IPv6 address by mapping ADDR onto it."))
 263 (defmethod map-ipv4-address->ipv6 ((addr ipv4addr))
 264   (make-instance 'ipv6addr
 265                  :name (map-ipv4-vector-to-ipv6 (name addr))))
 266
 267
 268 ;;; Constructor
 269 (defun make-address (name)
 270   (let (n)
 271     (cond
 272       ((stringp name)
 273        (make-instance 'localaddr :name name))
 274       ((setf n (ignore-errors
 275                  (coerce name '(simple-array ub8  (4)))))
 276        (make-instance 'ipv4addr :name n))
 277       ((setf n (ignore-errors
 278                  (coerce name '(simple-array ub16 (8)))))
 279        (make-instance 'ipv6addr :name n))
 280       (t (error 'invalid-address :address name :type :unknown)))))
 281
 282
 283 ;;;
 284 ;;; Well-known addresses
 285 ;;;
 286
 287 (defparameter +ipv4-unspecified+
 288   (make-address #(0 0 0 0)))
 289
 290 (defparameter +ipv4-loopback+
 291   (make-address #(127 0 0 1)))
 292
 293 (defparameter +ipv6-unspecified+
 294   (make-address #(0 0 0 0 0 0 0 0)))
 295
 296 (defparameter +ipv6-loopback+
 297   (make-address #(0 0 0 0 0 0 0 1)))
 298
 299 ;; Multicast addresses replacing IPv4 broadcast addresses
 300 (defparameter +ipv6-interface-local-all-nodes+
 301   (make-address #(#xFF01 0 0 0 0 0 0 1)))
 302
 303 (defparameter +ipv6-link-local-all-nodes+
 304   (make-address #(#xFF02 0 0 0 0 0 0 1)))
 305
 306 (defparameter +ipv6-interface-local-all-routers+
 307   (make-address #(#xFF01 0 0 0 0 0 0 2)))
 308
 309 (defparameter +ipv6-link-local-all-routers+
 310   (make-address #(#xFF02 0 0 0 0 0 0 2)))
 311
 312 (defparameter +ipv6-site-local-all-routers+
 313   (make-address #(#xFF05 0 0 0 0 0 0 2)))
 314
 315
 316 ;;;
 317 ;;; Predicates
 318 ;;;
 319
 320 ;; General predicates
 321 (defgeneric ipv4-address-p (addr)
 322   (:documentation "Returns T if ADDR is an IPv4 address object."))
 323
 324 (defmethod ipv4-address-p ((addr ipv4addr))
 325   t)
 326
 327 (defmethod ipv4-address-p (addr)
 328   nil)
 329
 330 (defgeneric ipv6-address-p (addr)
 331   (:documentation "Returns T if ADDR is an IPv6 address object."))
 332
 333 (defmethod ipv6-address-p ((addr ipv6addr))
 334   t)
 335
 336 (defmethod ipv6-address-p (addr)
 337   nil)
 338
 339 (defgeneric local-address-p (addr)
 340   (:documentation "Returns T if ADDR is local address object."))
 341
 342 (defmethod local-address-p ((addr localaddr))
 343   t)
 344
 345 (defmethod local-address-p (addr)
 346   nil)
 347
 348 (defmethod address-type ((address ipv4addr))
 349   :ipv4)
 350
 351 (defmethod address-type ((address ipv6addr))
 352   :ipv6)
 353
 354 (defmethod address-type ((address localaddr))
 355   :local)
 356
 357 (defmethod address-type (address)
 358   nil)
 359
 360 ;; IPv4 predicates
 361
 362 (defgeneric inetaddr-unspecified-p (addr)
 363   (:documentation "Returns T if ADDR is an \"unspecified\" internet address."))
 364 (defmethod inetaddr-unspecified-p ((addr ipv4addr))
 365   (sockaddr= addr +ipv4-unspecified+))
 366
 367 (defgeneric inetaddr-loopback-p (addr)
 368   (:documentation "Returns T if ADDR is a loopback internet address."))
 369 (defmethod inetaddr-loopback-p ((addr ipv4addr))
 370   (sockaddr= addr +ipv4-loopback+))
 371
 372 (defgeneric inetaddr-multicast-p (addr)
 373   (:documentation "Returns T if ADDR is an multicast internet address."))
 374 (defmethod inetaddr-multicast-p ((addr ipv4addr))
 375   (eql (logand (aref (name addr) 0)
 376                #xE0)
 377        #xE0))
 378
 379 (defgeneric inetaddr-unicast-p (addr)
 380   (:documentation "Returns T if ADDR is an unicast internet address."))
 381 (defmethod inetaddr-unicast-p ((addr ipv4addr))
 382   (and (not (inetaddr-unspecified-p addr))
 383        (not (inetaddr-loopback-p addr))
 384        (not (inetaddr-multicast-p addr))))
 385
 386 ;; IPv6 predicates
 387 ;; definitions taken from RFC 2460
 388
 389 (defmethod inetaddr-unspecified-p ((addr ipv6addr))
 390   (sockaddr= addr +ipv6-unspecified+))
 391
 392 (defmethod inetaddr-loopback-p ((addr ipv6addr))
 393   (sockaddr= addr +ipv6-loopback+))
 394
 395 (defgeneric ipv6-ipv4-mapped-p (addr)
 396   (:documentation "Returns T if ADDR is an IPv6 address representing an IPv4 mapped address."))
 397 (defmethod ipv6-ipv4-mapped-p ((addr ipv6addr))
 398   (with-slots (name) addr
 399     (and (zerop (aref name 0))
 400          (zerop (aref name 1))
 401          (zerop (aref name 2))
 402          (zerop (aref name 3))
 403          (zerop (aref name 4))
 404          (eql (aref name 5) #xFFFF)
 405          (< (ldb (byte 8 0) (aref name 6))
 406             255)
 407          (< (ldb (byte 8 8) (aref name 6))
 408             255)
 409          (< (ldb (byte 8 0) (aref name 7))
 410             255)
 411          (< (ldb (byte 8 8) (aref name 7))
 412             255))))
 413
 414 (defmethod inetaddr-multicast-p ((addr ipv6addr))
 415   (eql (logand (aref (name addr) 0)
 416                #xFF00)
 417        #xFF00))
 418
 419 (defgeneric ipv6-interface-local-multicast-p (addr)
 420   (:documentation "Returns T if ADDR is an interface-local IPv6 address."))
 421 (defmethod ipv6-interface-local-multicast-p ((addr ipv6addr))
 422   (eql (logand (aref (name addr) 0)
 423                #xFF0F)
 424        #xFF01))
 425
 426 (defgeneric ipv6-link-local-multicast-p (addr)
 427   (:documentation "Returns T if ADDR is a link-local IPv6 address."))
 428 (defmethod ipv6-link-local-multicast-p ((addr ipv6addr))
 429   (eql (logand (aref (name addr) 0)
 430                #xFF0F)
 431        #xFF02))
 432
 433 (defgeneric ipv6-admin-local-multicast-p (addr)
 434   (:documentation "Returns T if ADDR is a admin-local multicast IPv6 address."))
 435 (defmethod ipv6-admin-local-multicast-p ((addr ipv6addr))
 436   (eql (logand (aref (name addr) 0)
 437                #xFF0F)
 438        #xFF04))
 439
 440 (defgeneric ipv6-site-local-multicast-p (addr)
 441   (:documentation "Returns T if ADDR is an site-local multicast IPv6 address."))
 442 (defmethod ipv6-site-local-multicast-p ((addr ipv6addr))
 443   (eql (logand (aref (name addr) 0)
 444                #xFF0F)
 445        #xFF05))
 446
 447 (defgeneric ipv6-organization-local-multicast-p (addr)
 448   (:documentation "Returns T if ADDR is an organization-local multicast IPv6 address."))
 449 (defmethod ipv6-organization-local-multicast-p ((addr ipv6addr))
 450   (eql (logand (aref (name addr) 0)
 451                #xFF0F)
 452        #xFF08))
 453
 454 (defgeneric ipv6-global-multicast-p (addr)
 455   (:documentation "Returns T if ADDR is a global multicast IPv6 address."))
 456 (defmethod ipv6-global-multicast-p ((addr ipv6addr))
 457   (eql (logand (aref (name addr) 0)
 458                #xFF0F)
 459        #xFF0E))
 460
 461 (defgeneric ipv6-reserved-multicast-p (addr)
 462   (:documentation "Returns T if ADDR is a reserved multicast IPv6 address."))
 463 (defmethod ipv6-reserved-multicast-p ((addr ipv6addr))
 464   (member (logand (aref (name addr) 0)
 465                   #xFF0F)
 466           (list #xFF00 #xFF03 #xFF0F)))
 467
 468 (defgeneric ipv6-unassigned-multicast-p (addr)
 469   (:documentation "Returns T if ADDR is an unassigned multicast IPv6 address."))
 470 (defmethod ipv6-unassigned-multicast-p ((addr ipv6addr))
 471   (member (logand (aref (name addr) 0)
 472                   #xFF0F)
 473           (list #xFF06 #xFF07 #xFF09 #xFF0A #xFF0B #xFF0C #xFF0D)))
 474
 475 (defgeneric ipv6-transient-multicast-p (addr)
 476   (:documentation "Returns T if ADDR is a transient multicast IPv6 address."))
 477 (defmethod ipv6-transient-multicast-p ((addr ipv6addr))
 478   (eql (logand (aref (name addr) 0)
 479                #xFF10)
 480        #xFF10))
 481
 482 (defgeneric ipv6-solicited-node-multicast-p (addr)
 483   (:documentation "Returns T if ADDR is an solicited-node multicast IPv6 address."))
 484 (defmethod ipv6-solicited-node-multicast-p ((addr ipv6addr))
 485   (let ((vec (name addr)))
 486     (and (eql (aref vec 0) #xFF02) ; link-local permanent multicast
 487          (eql (aref vec 5) 1)
 488          (eql (logand (aref vec 6)
 489                       #xFF00)
 490               #xFF00))))
 491
 492 (defgeneric ipv6-link-local-unicast-p (addr)
 493   (:documentation "Returns T if ADDR is an link-local unicast IPv6 address."))
 494 (defmethod ipv6-link-local-unicast-p ((addr ipv6addr))
 495   (eql (aref (name addr) 0) #xFE80))
 496
 497 (defgeneric ipv6-site-local-unicast-p (addr)
 498   (:documentation "Returns T if ADDR is an site-local unicast IPv6 address."))
 499 (defmethod ipv6-site-local-unicast-p ((addr ipv6addr))
 500   (eql (aref (name addr) 0) #xFEC0))
 501
 502 (defgeneric ipv6-global-unicast-p (addr)
 503   (:documentation "Returns T if ADDR is an global unicasst IPv6 address."))
 504 (defmethod ipv6-global-unicast-p ((addr ipv6addr))
 505   (and (not (inetaddr-unspecified-p addr))
 506        (not (inetaddr-loopback-p addr))
 507        (not (inetaddr-multicast-p addr))
 508        (not (ipv6-link-local-unicast-p addr))))
 509
 510 (defmethod inetaddr-unicast-p ((addr ipv6addr))
 511   (or (ipv6-link-local-unicast-p addr)
 512       (and (not (inetaddr-unspecified-p addr))
 513            (not (inetaddr-loopback-p addr))
 514            (not (inetaddr-multicast-p addr)))))
 515
 516 (defgeneric ipv6-multicast-type (addr)
 517   (:documentation "Returns the multicast type of ADDR(which must be IPv6)."))
 518 (defmethod ipv6-multicast-type ((addr ipv6addr))
 519   (cond
 520     ((ipv6-interface-local-multicast-p addr)    :interface-local)
 521     ((ipv6-link-local-multicast-p addr)         :link-local)
 522     ((ipv6-admin-local-multicast-p addr)        :admin-local)
 523     ((ipv6-site-local-multicast-p addr)         :site-local)
 524     ((ipv6-organization-local-multicast-p addr) :organization-local)
 525     ((ipv6-global-multicast-p addr)             :global)
 526     ((ipv6-reserved-multicast-p addr)           :reserved)
 527     ((ipv6-unassigned-multicast-p addr)         :unassigned)))
 528
 529 (defgeneric inetaddr-type (addr)
 530   (:documentation "Returns the address type of ADDR."))
 531
 532 (defmethod inetaddr-type ((addr ipv6addr))
 533   (cond
 534     ((inetaddr-unspecified-p addr)    (values :ipv6 :unspecified))
 535     ((inetaddr-loopback-p addr)       (values :ipv6 :loopback))
 536     ((inetaddr-multicast-p addr)      (values :ipv6 :multicast (ipv6-multicast-type addr)))
 537     ((ipv6-link-local-unicast-p addr) (values :ipv6 :unicast :link-local))
 538     (t                                (values :ipv6 :unicast :global))))
 539
 540 (defmethod inetaddr-type ((addr ipv4addr))
 541   (cond
 542     ((inetaddr-unspecified-p addr) (values :ipv4 :unspecified))
 543     ((inetaddr-loopback-p addr)    (values :ipv4 :loopback))
 544     ((inetaddr-multicast-p addr)   (values :ipv4 :multicast))
 545     ((inetaddr-unicast-p addr)     (values :ipv4 :unicast))))