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