net.sockets/address-arithmetic.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Arithmetic with addresses and network masks.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (defun make-netmask (&key cidr class)
   9   "Create a subnet mask by specifying either its class(:A, :B or :C) or
  10 a CIDR suffix(a number between 0 and 32)."
  11   (assert (or cidr class) (cidr class) "You must either specify a CIDR or a network class.")
  12   (cond
  13     (cidr (check-type cidr (mod 33) "a number between 0 and 32"))
  14     (class (check-type class (member :a :b :c)
  15                        "a valid network class - one of :A, :B or :C")
  16            (setf cidr (case class (:a 8) (:b 16) (:c 24)))))
  17   (let ((mask #xFFFFFFFF))
  18     (declare (type ub32 mask))
  19     (setf (ldb (byte (- 32 cidr) 0) mask) 0)
  20     (make-instance 'ipv4-address :name (integer-to-vector mask))))
  21
  22 (defun ensure-netmask (thing)
  23   "If THING is of type IPV4-ADDRESS it is returned as is; if keyword it must be one of
  24 :A, :B or :C otherwise it's treated as a CIDR suffix."
  25   (etypecase thing
  26     (ipv4-address  thing)
  27     (unsigned-byte (make-netmask :cidr thing))
  28     (keyword       (make-netmask :class thing))))
  29
  30 (defgeneric inet-address-network-portion (address netmask)
  31   (:documentation "Apply network netmask NETMASK to ADDRESS in order to calculate the
  32 network part of ADDRESS.")
  33   (:method ((address ipv4-address) netmask)
  34     (setf netmask (ensure-netmask netmask))
  35     (let ((v (make-array 4 :element-type 'ub8))
  36           (av (address-name address))
  37           (mv (address-name netmask)))
  38       (dotimes (i 4)
  39         (setf (aref v i)
  40               (logand (aref av i)
  41                       (aref mv i))))
  42       (make-instance 'ipv4-address :name v))))
  43
  44 (defgeneric inet-address-host-portion (address netmask)
  45   (:documentation "Apply network netmask NETMASK to ADDRESS in order to calculate the
  46 host part of ADDRESS.")
  47   (:method ((address ipv4-address) netmask)
  48     (setf netmask (ensure-netmask netmask))
  49     (let ((v (make-array 4 :element-type 'ub8))
  50           (av (address-name address))
  51           (mv (address-name netmask)))
  52       (dotimes (i 4)
  53         (setf (aref v i)
  54               (logand (aref av i)
  55                       (logxor (aref mv i) 255))))
  56       (make-instance 'ipv4-address :name v))))
  57
  58 (defclass ipv4-network ()
  59   ((address :accessor address-of)
  60    (netmask :accessor netmask-of)
  61    (cidr :accessor cidr-of))
  62   (:documentation "IPv4 network: an address plus a netmask."))
  63
  64 (defun compute-cidr-prefix-from-netmask (netmask)
  65   (let ((ub32-address (vector-to-integer (address-name netmask))))
  66     (loop :with count := 0
  67        :for i :below 32
  68        :do (if (logbitp i ub32-address)
  69                (loop-finish)
  70                (incf count))
  71        :finally (return count))))
  72
  73 (defmethod initialize-instance :after ((network ipv4-network)
  74                                        &key address netmask)
  75   (check-type address ipv4-address "an Ipv4 address")
  76   (check-type netmask ipv4-address "an Ipv4 netmask")
  77   (setf (cidr-of network) (compute-cidr-prefix-from-netmask netmask))
  78   (setf (address-of network)
  79         (inet-address-network-portion address netmask)))
  80
  81 (defmethod print-object ((network ipv4-network) stream)
  82   (format stream "@~A/~A"
  83           (address-to-string (address-of network))
  84           (cidr-of network)))
  85
  86 (defgeneric ipv4-network= (net1 net2)
  87   (:documentation "Returns T if the addresses and the netmasks of the
  88 two arguments are respectively ADDRESS=.")
  89   (:method ((net1 ipv4-network) (net2 ipv4-network))
  90     (and (address= (address-of net1) (address-of net2))
  91          (address= (netmask-of net1) (netmask-of net2)))))
  92
  93 (defgeneric inet-address-in-network-p (address network)
  94   (:documentation "Return T if ADDRESS is part of the subnet specified by NETWORK.")
  95   (:method ((address ipv4-address) (network ipv4-network))
  96     (address= (inet-address-network-portion address (netmask-of network))
  97               (address-of network))))
  98
  99 (defgeneric inet-addresses-in-same-network-p (address1 address2 network)
 100   (:documentation "Return T if ADDRESS1 and ADDRESS2 are both part part of the
 101 subnet specified by NETWORK.")
 102   (:method ((address1 ipv4-address) (address2 ipv4-address) (network ipv4-network))
 103     (let ((address1-network (inet-address-network-portion address1 (netmask-of network)))
 104           (address2-network (inet-address-network-portion address2 (netmask-of network))))
 105       (and (address= address1-network (address-of network))
 106            (address= address2-network (address-of network))))))
 107
 108 (defgeneric inet-address-network-class (address)
 109   (:documentation "Return the network class of ADDRESS: one of :A, :B, :C, :D or :E .")
 110   (:method ((address ipv4-address))
 111     (let ((octet (aref (address-name address) 0)))
 112       (cond
 113         ((= #b0000 (ldb (byte 1 7) octet)) :a)
 114         ((= #b0010 (ldb (byte 2 6) octet)) :b)
 115         ((= #b0110 (ldb (byte 3 5) octet)) :c)
 116         ((= #b1110 (ldb (byte 4 4) octet)) :d)
 117         ((= #b1111 (ldb (byte 4 4) octet)) :e)))))
 118
 119 (defgeneric inet-address-private-p (address)
 120   (:documentation "Returns T if ADDRESS is in a private network range.
 121 Private IPv4 networks are 10.0.0.0/8, 172.16.0.0/12 and 192.168.0.0/16.
 122 See http://en.wikipedia.org/wiki/Private_network for details.")
 123   (:method ((address ipv4-address))
 124     (let* ((address-name (address-name address))
 125            (first (aref address-name 0))
 126            (second (aref address-name 1)))
 127       (values (or (= first 10)
 128                   (and (= first 172)
 129                        (<= 16 second 31))
 130                   (and (= first 192)
 131                        (= second 168)))
 132               (inet-address-network-class address))))
 133   (:method ((address address))
 134     nil))