src/sockets/address-arithmetic.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Arithmetic with addresses and network masks.
   4 ;;;
   5
   6 (in-package :iolib.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   (let ((namestring
  83          (format nil "~A/~A"
  84                  (address-to-string (address-of network))
  85                  (cidr-of network))))
  86     (if (or *print-readably* *print-escape*)
  87         (format stream "#/~S/~A" 'net namestring)
  88         (write-string namestring stream))))
  89
  90 (defgeneric ipv4-network= (net1 net2)
  91   (:documentation "Returns T if the addresses and the netmasks of the
  92 two arguments are respectively ADDRESS=.")
  93   (:method ((net1 ipv4-network) (net2 ipv4-network))
  94     (and (address= (address-of net1) (address-of net2))
  95          (address= (netmask-of net1) (netmask-of net2)))))
  96
  97 (defgeneric inet-address-in-network-p (address network)
  98   (:documentation "Return T if ADDRESS is part of the subnet specified by NETWORK.")
  99   (:method ((address ipv4-address) (network ipv4-network))
 100     (address= (inet-address-network-portion address (netmask-of network))
 101               (address-of network))))
 102
 103 (defgeneric inet-addresses-in-same-network-p (address1 address2 network)
 104   (:documentation "Return T if ADDRESS1 and ADDRESS2 are both part part of the
 105 subnet specified by NETWORK.")
 106   (:method ((address1 ipv4-address) (address2 ipv4-address) (network ipv4-network))
 107     (let ((address1-network (inet-address-network-portion address1 (netmask-of network)))
 108           (address2-network (inet-address-network-portion address2 (netmask-of network))))
 109       (and (address= address1-network (address-of network))
 110            (address= address2-network (address-of network))))))
 111
 112 (defgeneric inet-address-network-class (address)
 113   (:documentation "Return the network class of ADDRESS: one of :A, :B, :C, :D or :E .")
 114   (:method ((address ipv4-address))
 115     (let ((octet (aref (address-name address) 0)))
 116       (cond
 117         ((= #b0000 (ldb (byte 1 7) octet)) :a)
 118         ((= #b0010 (ldb (byte 2 6) octet)) :b)
 119         ((= #b0110 (ldb (byte 3 5) octet)) :c)
 120         ((= #b1110 (ldb (byte 4 4) octet)) :d)
 121         ((= #b1111 (ldb (byte 4 4) octet)) :e)))))
 122
 123 (defgeneric inet-address-private-p (address)
 124   (:documentation "Returns T if ADDRESS is in a private network range.
 125 Private IPv4 networks are 10.0.0.0/8, 172.16.0.0/12 and 192.168.0.0/16.
 126 See http://en.wikipedia.org/wiki/Private_network for details.")
 127   (:method ((address ipv4-address))
 128     (let* ((address-name (address-name address))
 129            (first (aref address-name 0))
 130            (second (aref address-name 1)))
 131       (values (or (= first 10)
 132                   (and (= first 172)
 133                        (<= 16 second 31))
 134                   (and (= first 192)
 135                        (= second 168)))
 136               (inet-address-network-class address))))
 137   (:method ((address address))
 138     nil))