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 (error-p t))
  59   (handler-case
  60       (setf string (coerce string '(vector base-char)))
  61     (type-error (err)
  62       (declare (ignore err))
  63       (if error-p
  64           (error 'invalid-argument :argument string
  65                  :message (format nil "The vector: ~A is not a string or contains non-ASCII characters." string))
  66           (return-from dotted-to-vector nil))))
  67
  68   (with-alien ((in-addr et:in-addr-t))
  69     (sb-sys:with-pinned-objects (string)
  70       (setf in-addr 0)
  71       (handler-case
  72           (et:inet-pton et:af-inet        ; address family
  73                         string            ; name
  74                         (addr in-addr))   ; pointer to struct in6_addr
  75         (unix-error (err)
  76           (declare (ignore err))
  77           (if error-p
  78               (error 'invalid-address :address string :type :ipv4)
  79               (return-from dotted-to-vector nil)))))
  80     (make-vector-u8-4-from-in-addr in-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 (error-p t))
  94   (handler-case
  95       (setf string (coerce string '(simple-array base-char (*))))
  96     (type-error (err)
  97       (declare (ignore err))
  98       (if error-p
  99           (error 'invalid-argument :argument string
 100                  :message (format nil "The vector: ~A is not a string or contains non-ASCII characters." string))
 101           (return-from colon-separated-to-vector nil))))
 102
 103   (with-alien ((in6-addr et:in6-addr))
 104     (sb-sys:with-pinned-objects (string)
 105       (et:memset (addr in6-addr) 0 et::size-of-in6-addr)
 106       (handler-case
 107           (et:inet-pton et:af-inet6        ; address family
 108                         string             ; name
 109                         (addr in6-addr)) ; pointer to struct in6_addr
 110         (unix-error (err)
 111           (declare (ignore err))
 112           (if error-p
 113               (error 'invalid-address :address string :type :ipv4)
 114               (return-from colon-separated-to-vector nil)))))
 115     (make-vector-u16-8-from-in6-addr (addr in6-addr))))
 116
 117 (defun vector-to-colon-separated (vector &key (case :downcase) (error-p t))
 118   (handler-case
 119       (setf vector (coerce vector '(simple-array ub16 (8))))
 120     (type-error (err)
 121       (declare (ignore err))
 122       (if error-p
 123           (error 'invalid-argument :argument vector
 124                  :message (format nil "The vector: ~A does not contain only 16-bit positive integers or has not length 8." vector))
 125           (return-from vector-to-colon-separated nil))))
 126
 127   (with-alien
 128       ((sin6 et:sockaddr-in6)
 129        (namebuff (array (unsigned 8) #.et:inet6-addrstrlen)))
 130     (make-sockaddr-in6 (addr sin6) vector)
 131     (et:inet-ntop et:af-inet6                    ; address family
 132                   (addr (slot sin6 'et:address)) ; pointer to struct in6_addr
 133                   (alien-sap namebuff)           ; destination buffer
 134                   et:inet6-addrstrlen)           ; INET6_ADDRSTRLEN
 135     (return-from vector-to-colon-separated
 136       (let ((str (cast namebuff c-string)))
 137         (ecase case
 138           (:downcase str)
 139           (:upcase (nstring-upcase str)))))))
 140
 141 (defun string-address->vector (address)
 142   (or (dotted-to-vector address :error-p nil)
 143       (colon-separated-to-vector address :error-p 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 :error-p nil))
 150                  (setf addr-type :ipv4))
 151                 ((setf vector (colon-separated-to-vector address :error-p 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 netaddr ()
 171   ((name :initarg :name :reader name :type vector))
 172   (:documentation "Base class for the internet addresses."))
 173
 174 (defclass ipv4addr (netaddr) ()
 175   (:documentation "IPv4 address."))
 176
 177 (defclass ipv6addr (netaddr) ()
 178   (:documentation "IPv6 address."))
 179
 180 (defclass localaddr (netaddr)
 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" (vector-to-dotted name)))))
 193
 194 (defmethod print-object ((address ipv6addr) stream)
 195   (print-unreadable-object (address stream :type nil :identity nil)
 196     (with-slots (name) address
 197       (format stream "IPv6 address: ~A" (vector-to-colon-separated name)))))
 198
 199 (defmethod print-object ((address localaddr) stream)
 200   (print-unreadable-object (address stream :type nil :identity nil)
 201     (with-slots (name abstract) address
 202       (format stream "Unix socket address: ~A. Abstract: ~:[no~;yes~]" name abstract))))
 203
 204 (defmethod netaddr->presentation ((addr ipv4addr))
 205   (vector-to-dotted (name addr)))
 206
 207 (defmethod netaddr->presentation ((addr ipv6addr))
 208   (vector-to-colon-separated (name addr)))
 209
 210 (defmethod netaddr->presentation ((addr localaddr))
 211   (name addr))
 212
 213
 214 ;;;
 215 ;;; Equality methods
 216 ;;;
 217
 218 (defun vector-equal (v1 v2)
 219   (and (typep v1 'vector)
 220        (equal (type-of v1) (type-of v2))
 221        (every #'eql v1 v2)))
 222
 223 (defmethod netaddr= ((addr1 ipv4addr) (addr2 ipv4addr))
 224   (vector-equal (name addr1) (name addr2)))
 225
 226 (defmethod netaddr= ((addr1 ipv6addr) (addr2 ipv6addr))
 227   (vector-equal (name addr1) (name addr2)))
 228
 229 (defmethod netaddr= ((addr1 localaddr) (addr2 localaddr))
 230   (equal (name addr1) (name addr2)))
 231
 232
 233 ;;;
 234 ;;; Copy methods
 235 ;;;
 236
 237 (defmethod copy-netaddr ((addr ipv4addr))
 238   (make-instance 'ipv4addr
 239                  :name (copy-seq (name addr))))
 240
 241 (defmethod copy-netaddr ((addr ipv6addr))
 242   (make-instance 'ipv6addr
 243                  :name (copy-seq (name addr))))
 244
 245 (defmethod copy-netaddr ((addr localaddr))
 246   (make-instance 'localaddr
 247                  :name (copy-seq (name addr))
 248                  :abstract (abstract-p addr)))
 249
 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   (let (n)
 258     (cond
 259       ((stringp name)
 260        (make-instance 'localaddr :name name))
 261       ((setf n (ignore-errors
 262                  (coerce name '(simple-array ub8  (4)))))
 263        (make-instance 'ipv4addr :name n))
 264       ((setf n (ignore-errors
 265                  (coerce name '(simple-array ub16 (8)))))
 266        (make-instance 'ipv6addr :name n))
 267       (t (error 'invalid-address :address name :type :unknown)))))
 268
 269
 270 ;;;
 271 ;;; Well-known addresses
 272 ;;;
 273
 274 (defparameter +ipv4-unspecified+
 275   (make-address #(0 0 0 0)))
 276
 277 (defparameter +ipv4-loopback+
 278   (make-address #(127 0 0 1)))
 279
 280 (defparameter +ipv6-unspecified+
 281   (make-address #(0 0 0 0 0 0 0 0)))
 282
 283 (defparameter +ipv6-loopback+
 284   (make-address #(0 0 0 0 0 0 0 1)))
 285
 286 ;; Multicast addresses replacing IPv4 broadcast addresses
 287 (defparameter +ipv6-interface-local-all-nodes+
 288   (make-address #(#xFF01 0 0 0 0 0 0 1)))
 289
 290 (defparameter +ipv6-link-local-all-nodes+
 291   (make-address #(#xFF02 0 0 0 0 0 0 1)))
 292
 293 (defparameter +ipv6-interface-local-all-routers+
 294   (make-address #(#xFF01 0 0 0 0 0 0 2)))
 295
 296 (defparameter +ipv6-link-local-all-routers+
 297   (make-address #(#xFF02 0 0 0 0 0 0 2)))
 298
 299 (defparameter +ipv6-site-local-all-routers+
 300   (make-address #(#xFF05 0 0 0 0 0 0 2)))
 301
 302
 303 ;;;
 304 ;;; Predicates
 305 ;;;
 306
 307 ;; General predicates
 308 (defmethod ipv4-address-p ((addr ipv4addr))
 309   t)
 310
 311 (defmethod ipv4-address-p (addr)
 312   nil)
 313
 314 (defmethod ipv6-address-p ((addr ipv6addr))
 315   t)
 316
 317 (defmethod ipv6-address-p (addr)
 318   nil)
 319
 320 (defmethod local-address-p ((addr localaddr))
 321   t)
 322
 323 (defmethod local-address-p (addr)
 324   nil)
 325
 326 (defmethod address-type ((address ipv4addr))
 327   :ipv4)
 328
 329 (defmethod address-type ((address ipv6addr))
 330   :ipv6)
 331
 332 (defmethod address-type ((address localaddr))
 333   :local)
 334
 335 (defmethod address-type (address)
 336   nil)
 337
 338 ;; IPv4 predicates
 339
 340 (defmethod netaddr-unspecified-p ((addr ipv4addr))
 341   (netaddr= addr +ipv4-unspecified+))
 342
 343 (defmethod netaddr-loopback-p ((addr ipv4addr))
 344   (netaddr= addr +ipv4-loopback+))
 345
 346 (defmethod netaddr-multicast-p ((addr ipv4addr))
 347   (eql (logand (aref (name addr) 0)
 348                #xE0)
 349        #xE0))
 350
 351 (defmethod netaddr-unicast-p ((addr ipv4addr))
 352   (and (not (netaddr-unspecified-p addr))
 353        (not (netaddr-loopback-p addr))
 354        (not (netaddr-multicast-p addr))))
 355
 356 ;; IPv6 predicates
 357 ;; definitions taken from RFC 2460
 358
 359 (defmethod netaddr-unspecified-p ((addr ipv6addr))
 360   (netaddr= addr +ipv6-unspecified+))
 361
 362 (defmethod netaddr-loopback-p ((addr ipv6addr))
 363   (netaddr= addr +ipv6-loopback+))
 364
 365 (defmethod ipv6-ipv4-mapped-p ((addr ipv6addr))
 366   (with-slots (name) addr
 367     (and (zerop (aref name 0))
 368          (zerop (aref name 1))
 369          (zerop (aref name 2))
 370          (zerop (aref name 3))
 371          (zerop (aref name 4))
 372          (eql (aref name 5) #xFFFF)
 373          (< (ldb (byte 8 0) (aref name 6))
 374             255)
 375          (< (ldb (byte 8 8) (aref name 6))
 376             255)
 377          (< (ldb (byte 8 0) (aref name 7))
 378             255)
 379          (< (ldb (byte 8 8) (aref name 7))
 380             255))))
 381
 382 (defmethod netaddr-multicast-p ((addr ipv6addr))
 383   (eql (logand (aref (name addr) 0)
 384                #xFF00)
 385        #xFF00))
 386
 387 (defmethod ipv6-interface-local-multicast-p ((addr ipv6addr))
 388   (eql (logand (aref (name addr) 0)
 389                #xFF0F)
 390        #xFF01))
 391
 392 (defmethod ipv6-link-local-multicast-p ((addr ipv6addr))
 393   (eql (logand (aref (name addr) 0)
 394                #xFF0F)
 395        #xFF02))
 396
 397 (defmethod ipv6-admin-local-multicast-p ((addr ipv6addr))
 398   (eql (logand (aref (name addr) 0)
 399                #xFF0F)
 400        #xFF04))
 401
 402 (defmethod ipv6-site-local-multicast-p ((addr ipv6addr))
 403   (eql (logand (aref (name addr) 0)
 404                #xFF0F)
 405        #xFF05))
 406
 407 (defmethod ipv6-organization-local-multicast-p ((addr ipv6addr))
 408   (eql (logand (aref (name addr) 0)
 409                #xFF0F)
 410        #xFF08))
 411
 412 (defmethod ipv6-global-multicast-p ((addr ipv6addr))
 413   (eql (logand (aref (name addr) 0)
 414                #xFF0F)
 415        #xFF0E))
 416
 417 (defmethod ipv6-reserved-multicast-p ((addr ipv6addr))
 418   (member (logand (aref (name addr) 0)
 419                   #xFF0F)
 420           (list #xFF00 #xFF03 #xFF0F)))
 421
 422 (defmethod ipv6-unassigned-multicast-p ((addr ipv6addr))
 423   (member (logand (aref (name addr) 0)
 424                   #xFF0F)
 425           (list #xFF06 #xFF07 #xFF09 #xFF0A #xFF0B #xFF0C #xFF0D)))
 426
 427 (defmethod ipv6-transient-multicast-p ((addr ipv6addr))
 428   (eql (logand (aref (name addr) 0)
 429                #xFF10)
 430        #xFF10))
 431
 432 (defmethod ipv6-solicited-node-multicast-p ((addr ipv6addr))
 433   (let ((vec (name addr)))
 434     (and (eql (aref vec 0) #xFF02) ; link-local permanent multicast
 435          (eql (aref vec 5) 1)
 436          (eql (logand (aref vec 6)
 437                       #xFF00)
 438               #xFF00))))
 439
 440 (defmethod ipv6-link-local-unicast-p ((addr ipv6addr))
 441   (eql (aref (name addr) 0) #xFE80))
 442
 443 (defmethod ipv6-site-local-unicast-p ((addr ipv6addr))
 444   (eql (aref (name addr) 0) #xFEC0))
 445
 446 (defmethod ipv6-global-unicast-p ((addr ipv6addr))
 447   (and (not (netaddr-unspecified-p addr))
 448        (not (netaddr-loopback-p addr))
 449        (not (netaddr-multicast-p addr))
 450        (not (ipv6-link-local-unicast-p addr))))
 451
 452 (defmethod netaddr-unicast-p ((addr ipv6addr))
 453   (or (ipv6-link-local-unicast-p addr)
 454       (and (not (netaddr-unspecified-p addr))
 455            (not (netaddr-loopback-p addr))
 456            (not (netaddr-multicast-p addr)))))
 457
 458 (defmethod ipv6-multicast-type ((addr ipv6addr))
 459   (cond
 460     ((ipv6-interface-local-multicast-p addr)    :interface-local)
 461     ((ipv6-link-local-multicast-p addr)         :link-local)
 462     ((ipv6-admin-local-multicast-p addr)        :admin-local)
 463     ((ipv6-site-local-multicast-p addr)         :site-local)
 464     ((ipv6-organization-local-multicast-p addr) :organization-local)
 465     ((ipv6-global-multicast-p addr)             :global)
 466     ((ipv6-reserved-multicast-p addr)           :reserved)
 467     ((ipv6-unassigned-multicast-p addr)         :unassigned)))
 468
 469 (defmethod netaddr-type ((addr ipv6addr))
 470   (cond
 471     ((netaddr-unspecified-p addr)        (values :ipv6 :unspecified))
 472     ((netaddr-loopback-p addr)           (values :ipv6 :loopback))
 473     ((netaddr-multicast-p addr)          (values :ipv6 :multicast (ipv6-multicast-type addr)))
 474     ((ipv6-link-local-unicast-p addr)    (values :ipv6 :unicast :link-local))
 475     (t                                   (values :ipv6 :unicast :global))))
 476
 477 (defmethod netaddr-type ((addr ipv4addr))
 478   (cond
 479     ((netaddr-unspecified-p addr)        (values :ipv4 :unspecified))
 480     ((netaddr-loopback-p addr)           (values :ipv4 :loopback))
 481     ((netaddr-multicast-p addr)          (values :ipv4 :multicast))
 482     ((netaddr-unicast-p addr)            (values :ipv4 :unicast))))