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