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