sockets/address.lisp

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