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