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