src/Cidr.hs

   1 -- | The CIDR modules contains most of the functions used for working
   2 --   with the CIDR type.
   3 module Cidr
   4 ( Cidr(..),
   5   cidr_properties,
   6   cidr_tests,
   7   combine_all,
   8   contains,
   9   contains_proper,
  10   enumerate,
  11   max_octet1,
  12   max_octet2,
  13   max_octet3,
  14   max_octet4,
  15   min_octet1,
  16   min_octet2,
  17   min_octet3,
  18   min_octet4,
  19 ) where
  20
  21 import Data.List (nubBy)
  22 import Data.List.Split (splitOneOf)
  23 import Data.Maybe (catMaybes, mapMaybe)
  24
  25 import Test.QuickCheck ( Gen ) -- Not re-exported by tasty
  26 import Test.Tasty ( TestTree, testGroup )
  27 import Test.Tasty.HUnit ( (@?=), testCase )
  28 import Test.Tasty.QuickCheck (
  29   Arbitrary(..),
  30   Property,
  31   (==>),
  32   testProperty )
  33 import Text.Read (readMaybe)
  34
  35 import qualified Bit as B (Bit(..))
  36 import IPv4Address (IPv4Address(..), most_sig_bit_different)
  37 import Maskable (Maskable(..))
  38 import Maskbits (Maskbits(..))
  39 import Octet (Octet(..))
  40
  41
  42 data Cidr = Cidr { ipv4address :: IPv4Address,
  43                    maskbits :: Maskbits }
  44
  45
  46 instance Show Cidr where
  47     show cidr = (show (ipv4address cidr)) ++ "/" ++ (show (maskbits cidr))
  48
  49
  50 instance Arbitrary Cidr where
  51     arbitrary = do
  52       ipv4 <- arbitrary :: Gen IPv4Address
  53       mask <- arbitrary :: Gen Maskbits
  54       return (Cidr ipv4 mask)
  55
  56
  57 instance Eq Cidr where
  58   cidr1 == cidr2 = (cidr1 `equivalent` cidr2)
  59
  60
  61 -- | Two CIDR ranges are equivalent if they have the same network bits
  62 --   and the masks are the same.
  63 equivalent :: Cidr -> Cidr -> Bool
  64 equivalent (Cidr addr1 mbits1) (Cidr addr2 mbits2) =
  65     (mbits1 == mbits2) && ((apply_mask addr1 mbits1 B.Zero) == (apply_mask addr2 mbits2 B.Zero))
  66
  67 -- | Returns the mask portion of a CIDR address. That is, everything
  68 --   after the trailing slash.
  69 maskbits_from_cidr_string :: String -> Maybe Maskbits
  70 maskbits_from_cidr_string s
  71   | length partlist == 2 = readMaybe (partlist !! 1)
  72   | otherwise = Nothing
  73     where
  74       partlist = splitOneOf "/" s
  75
  76
  77 -- | Takes an IP address String in CIDR notation, and returns a list
  78 --   of its octets (as Ints).
  79 octets_from_cidr_string :: String -> [Octet]
  80 octets_from_cidr_string s =
  81   case parts of
  82     (p1:p2:p3:p4:_) -> mapMaybe readMaybe [p1,p2,p3,p4]
  83     _ -> []
  84   where
  85     parts = splitOneOf "./" s
  86
  87 instance Read Cidr where
  88   -- | Parse everything or nothing.
  89   readsPrec _ s =
  90     case (octets_from_cidr_string s) of
  91       [oct1, oct2, oct3, oct4] ->
  92         case (maskbits_from_cidr_string s) of
  93           Just mbits ->
  94             [(Cidr (IPv4Address oct1 oct2 oct3 oct4) mbits, "")]
  95           _ -> []
  96       _ -> []
  97
  98
  99 -- | Given a CIDR, return the minimum valid IPv4 address contained
 100 --   within it.
 101 min_host :: Cidr -> IPv4Address
 102 min_host (Cidr addr mask) = apply_mask addr mask B.Zero
 103
 104 -- | Given a CIDR, return the maximum valid IPv4 address contained
 105 --   within it.
 106 max_host :: Cidr -> IPv4Address
 107 max_host (Cidr addr mask) = apply_mask addr mask B.One
 108
 109 -- | Given a CIDR, return the first octet of the minimum valid IPv4
 110 --   address contained within it.
 111 min_octet1 :: Cidr -> Octet
 112 min_octet1 cidr = octet1 (min_host cidr)
 113
 114 -- | Given a CIDR, return the second octet of the minimum valid IPv4
 115 --   address contained within it.
 116 min_octet2 :: Cidr -> Octet
 117 min_octet2 cidr = octet2 (min_host cidr)
 118
 119 -- | Given a CIDR, return the third octet of the minimum valid IPv4
 120 --   address contained within it.
 121 min_octet3 :: Cidr -> Octet
 122 min_octet3 cidr = octet3 (min_host cidr)
 123
 124 -- | Given a CIDR, return the fourth octet of the minimum valid IPv4
 125 --   address contained within it.
 126 min_octet4 :: Cidr -> Octet
 127 min_octet4 cidr = octet4 (min_host cidr)
 128
 129 -- | Given a CIDR, return the first octet of the maximum valid IPv4
 130 --   address contained within it.
 131 max_octet1 :: Cidr -> Octet
 132 max_octet1 cidr = octet1 (max_host cidr)
 133
 134 -- | Given a CIDR, return the second octet of the maximum valid IPv4
 135 --   address contained within it.
 136 max_octet2 :: Cidr -> Octet
 137 max_octet2 cidr = octet2 (max_host cidr)
 138
 139 -- | Given a CIDR, return the third octet of the maximum valid IPv4
 140 --   address contained within it.
 141 max_octet3 :: Cidr -> Octet
 142 max_octet3 cidr = octet3 (max_host cidr)
 143
 144 -- | Given a CIDR, return the fourth octet of the maximum valid IPv4
 145 --   address contained within it.
 146 max_octet4 :: Cidr -> Octet
 147 max_octet4 cidr = octet4 (max_host cidr)
 148
 149
 150
 151 -- | Return true if the first argument (a CIDR range) contains the
 152 --   second (another CIDR range). There are a lot of ways we can be
 153 --   fed junk here. For lack of a better alternative, just return
 154 --   False when we are given nonsense.
 155 --
 156 --   If the number of bits in the network part of the first address is
 157 --   larger than the number of bits in the second, there is no way
 158 --   that the first range can contain the second. For, if the number
 159 --   of network bits is larger, then the number of host bits must be
 160 --   smaller, and if cidr1 has fewer hosts than cidr2, cidr1 most
 161 --   certainly does not contain cidr2.
 162 --
 163 --   On the other hand, if the first argument (cidr1) has fewer (or
 164 --   the same number of) network bits as the second, it can contain
 165 --   the second. In this case, we need to check that every host in
 166 --   cidr2 is contained in cidr1. If a host in cidr2 is contained in
 167 --   cidr1, then at least mbits1 of an address in cidr2 will match
 168 --   cidr1. For example,
 169 --
 170 --   cidr1 = 192.168.1.0\/23, cidr2 = 192.168.1.100\/24
 171 --
 172 --   Here, cidr2 contains all of 192.168.1.0 through
 173 --   192.168.1.255. However, cidr1 contains BOTH 192.168.0.0 through
 174 --   192.168.0.255 and 192.168.1.0 through 192.168.1.255. In essence,
 175 --   what we want to check is that cidr2 "begins with" something that
 176 --   cidr1 CAN begin with. Since cidr1 can begin with 192.168.1, and
 177 --   cidr2 DOES, cidr1 contains cidr2..
 178 --
 179 --   The way that we check this is to apply cidr1's mask to cidr2's
 180 --   address and see if the result is the same as cidr1's mask applied
 181 --   to cidr1's address.
 182 --
 183 contains :: Cidr -> Cidr -> Bool
 184 contains (Cidr addr1 mbits1) (Cidr addr2 mbits2)
 185   | mbits1 > mbits2 = False
 186   | otherwise = addr1masked == addr2masked
 187   where
 188     addr1masked = apply_mask addr1 mbits1 B.Zero
 189     addr2masked = apply_mask addr2 mbits1 B.Zero
 190
 191
 192 -- | Contains but is not equal to.
 193 contains_proper :: Cidr -> Cidr -> Bool
 194 contains_proper cidr1 cidr2 =
 195     (cidr1 `contains` cidr2) && (not (cidr2 `contains` cidr1))
 196
 197
 198 -- | A CIDR range is redundant (with respect to the given list) if
 199 --   another CIDR range in that list properly contains it.
 200 redundant :: [Cidr] -> Cidr -> Bool
 201 redundant cidrlist cidr = any ((flip contains_proper) cidr) cidrlist
 202
 203
 204 -- | First, we look at all possible pairs of cidrs, and combine the
 205 --   adjacent ones in to a new list. Then, we concatenate that list
 206 --   with the original one, and filter out all of the redundancies. If
 207 --   two adjacent Cidrs are combined into a larger one, they will be
 208 --   removed in the second step since the larger Cidr must contain the
 209 --   smaller two.
 210 --
 211 --   Once this is done, we see whether or not the result is different
 212 --   than the argument that was passed in. If nothing changed, we're
 213 --   done and return the list that was passed to us. However, if
 214 --   something changed, we recurse and try to combine the list again.
 215 combine_all :: [Cidr] -> [Cidr]
 216 combine_all cidrs
 217   | cidrs == (combine_contained unique_cidrs) = cidrs
 218   | otherwise = combine_all (combine_contained unique_cidrs)
 219     where
 220       unique_cidrs = nubBy equivalent cidr_combinations
 221       cidr_combinations =
 222         cidrs ++ (catMaybes [ (combine_adjacent x y) | x <- cidrs, y <- cidrs ])
 223
 224
 225 -- | Take a list of CIDR ranges and filter out all of the ones that
 226 --   are contained entirelt within some other range in the list.
 227 combine_contained :: [Cidr] -> [Cidr]
 228 combine_contained cidrs =
 229   filter (not . (redundant cidrs)) cidrs
 230
 231
 232 -- | If the two Cidrs are not adjacent, return Cidr.None. Otherwise,
 233 --   decrement the maskbits of cidr1 and return that; it will contain
 234 --   both cidr1 and cidr2.
 235 combine_adjacent :: Cidr -> Cidr -> Maybe Cidr
 236 combine_adjacent cidr1 cidr2
 237   | not (adjacent cidr1 cidr2) = Nothing
 238   | (maskbits cidr1 == Zero) = Nothing
 239   | otherwise = Just $ cidr1 { maskbits = pred (maskbits cidr1) }
 240
 241
 242
 243 -- | Determine whether or not two CIDR ranges are adjacent. If two
 244 --   ranges lie consecutively within the IP space, they can be
 245 --   combined. For example, 10.1.0.0/24 and 10.0.1.0/24 are adjacent,
 246 --   and can be combined in to 10.1.0.0/23.
 247 adjacent :: Cidr -> Cidr -> Bool
 248 adjacent cidr1 cidr2
 249   | mbits1 /= mbits2 = False
 250   | mbits1 == Maskbits.Zero = False -- They're equal.
 251   | otherwise = (mbits1 == (most_sig_bit_different addr1 addr2))
 252   where
 253     addr1 = ipv4address cidr1
 254     addr2 = ipv4address cidr2
 255     mbits1 = maskbits cidr1
 256     mbits2 = maskbits cidr2
 257
 258
 259 enumerate :: Cidr -> [IPv4Address]
 260 enumerate cidr = [(min_host cidr)..(max_host cidr)]
 261
 262 -- Test lists.
 263 cidr_tests :: TestTree
 264 cidr_tests =
 265   testGroup "CIDR Tests" [
 266     test_enumerate,
 267     test_min_host1,
 268     test_max_host1,
 269     test_equality1,
 270     test_contains1,
 271     test_contains2,
 272     test_contains_proper1,
 273     test_contains_proper2,
 274     test_adjacent1,
 275     test_adjacent2,
 276     test_adjacent3,
 277     test_adjacent4,
 278     test_combine_contained1,
 279     test_combine_contained2,
 280     test_combine_all1,
 281     test_combine_all2,
 282     test_combine_all3 ]
 283
 284 cidr_properties :: TestTree
 285 cidr_properties =
 286   testGroup "CIDR Properties" [
 287       prop_all_cidrs_contain_themselves,
 288       prop_contains_proper_antisymmetric ]
 289
 290
 291 -- HUnit Tests
 292 test_enumerate :: TestTree
 293 test_enumerate =
 294   testCase desc $ actual @?= expected
 295   where
 296     desc = "192.168.0.240/30 is enumerated correctly"
 297     oct1 = toEnum 192
 298     oct2 = toEnum 168
 299     oct3 = minBound
 300     mk_ip = IPv4Address oct1 oct2 oct3
 301     addr1 = mk_ip $ toEnum 240
 302     addr2 = mk_ip $ toEnum 241
 303     addr3 = mk_ip $ toEnum 242
 304     addr4 = mk_ip $ toEnum 243
 305     expected = [addr1, addr2, addr3, addr4]
 306     actual = enumerate $ read "192.168.0.240/30"
 307
 308 test_min_host1 :: TestTree
 309 test_min_host1 =
 310   testCase desc $ actual @?= expected
 311   where
 312     desc = "The minimum host in 10.0.0.0/24 is 10.0.0.0"
 313     actual = show $ min_host (read "10.0.0.0/24")
 314     expected = "10.0.0.0"
 315
 316
 317 test_max_host1 :: TestTree
 318 test_max_host1 =
 319   testCase desc $ actual @?= expected
 320   where
 321     desc = "The maximum host in 10.0.0.0/24 is 10.0.0.255"
 322     actual = show $ max_host (read "10.0.0.0/24")
 323     expected = "10.0.0.255"
 324
 325
 326 test_equality1 :: TestTree
 327 test_equality1 =
 328   testCase desc $ actual @?= expected
 329   where
 330     desc = "10.1.1.0/23 equals itself"
 331     actual = read "10.1.1.0/23" :: Cidr
 332     expected = read "10.1.1.0/23" :: Cidr
 333
 334
 335 test_contains1 :: TestTree
 336 test_contains1 =
 337   testCase desc $ actual @?= expected
 338   where
 339     desc = "10.1.1.0/23 contains 10.1.1.0/24"
 340     cidr1 = read "10.1.1.0/23"
 341     cidr2 = read "10.1.1.0/24"
 342     expected = True
 343     actual = cidr1 `contains` cidr2
 344
 345
 346 test_contains2 :: TestTree
 347 test_contains2 =
 348   testCase desc $ actual @?= expected
 349   where
 350     desc = "10.1.1.0/23 contains itself"
 351     cidr1 = read "10.1.1.0/23"
 352     expected = True
 353     actual = cidr1 `contains` cidr1
 354
 355
 356 test_contains_proper1 :: TestTree
 357 test_contains_proper1 =
 358   testCase desc $ actual @?= expected
 359   where
 360     desc = "10.1.1.0/23 contains 10.1.1.0/24 properly"
 361     cidr1 = read "10.1.1.0/23"
 362     cidr2 = read "10.1.1.0/24"
 363     expected = True
 364     actual = cidr1 `contains_proper` cidr2
 365
 366
 367 test_contains_proper2 :: TestTree
 368 test_contains_proper2 =
 369   testCase desc $ actual @?= expected
 370   where
 371     desc = "10.1.1.0/23 does not contain itself properly"
 372     cidr1 = read "10.1.1.0/23"
 373     expected = False
 374     actual = cidr1 `contains_proper` cidr1
 375
 376
 377 test_adjacent1 :: TestTree
 378 test_adjacent1 =
 379   testCase desc $ actual @?= expected
 380   where
 381     desc = "10.1.0.0/24 is adjacent to 10.1.1.0/24"
 382     cidr1 = read "10.1.0.0/24"
 383     cidr2 = read "10.1.1.0/24"
 384     expected = True
 385     actual = cidr1 `adjacent` cidr2
 386
 387
 388 test_adjacent2 :: TestTree
 389 test_adjacent2 =
 390   testCase desc $ actual @?= expected
 391   where
 392     desc = "10.1.0.0/23 is not adjacent to 10.1.0.0/24"
 393     cidr1 = read "10.1.0.0/23"
 394     cidr2 = read "10.1.0.0/24"
 395     expected = False
 396     actual = cidr1 `adjacent` cidr2
 397
 398
 399 test_adjacent3 :: TestTree
 400 test_adjacent3 =
 401   testCase desc $ actual @?= expected
 402   where
 403     desc = "10.1.0.0/24 is not adjacent to 10.2.5.0/24"
 404     cidr1 = read "10.1.0.0/24"
 405     cidr2 = read "10.2.5.0/24"
 406     expected = False
 407     actual = cidr1 `adjacent` cidr2
 408
 409
 410 test_adjacent4 :: TestTree
 411 test_adjacent4 =
 412   testCase desc $ actual @?= expected
 413   where
 414     desc = "10.1.1.0/24 is not adjacent to 10.1.2.0/24"
 415     cidr1 = read "10.1.1.0/24"
 416     cidr2 = read "10.1.2.0/24"
 417     expected = False
 418     actual = cidr1 `adjacent` cidr2
 419
 420 test_combine_contained1 :: TestTree
 421 test_combine_contained1 =
 422   testCase desc $ actual @?= expected
 423   where
 424     desc = "10.0.0.0/8, 10.1.0.0/16, and 10.1.1.0/24 combine to 10.0.0.0/8"
 425     cidr1 = read "10.0.0.0/8"
 426     cidr2 = read "10.1.0.0/16"
 427     cidr3 = read "10.1.1.0/24"
 428     test_cidrs = [cidr1, cidr2, cidr3]
 429     expected = [cidr1]
 430     actual = combine_contained test_cidrs
 431
 432 test_combine_contained2 :: TestTree
 433 test_combine_contained2 =
 434   testCase desc $ actual @?= expected
 435   where
 436     desc = "192.168.3.0/23 does not contain 192.168.1.0/24"
 437     cidr1 = read "192.168.3.0/23"
 438     cidr2 = read "192.168.1.0/24"
 439     expected = [cidr1, cidr2]
 440     actual = combine_contained [cidr1, cidr2]
 441
 442
 443 test_combine_all1 :: TestTree
 444 test_combine_all1 =
 445   testCase desc $ actual @?= expected
 446   where
 447     desc = "10.0.0.0/24 is adjacent to 10.0.1.0/24 "
 448            ++ "and 10.0.3.0/23 contains 10.0.2.0/24"
 449     cidr1 = read "10.0.0.0/24"
 450     cidr2 = read "10.0.1.0/24"
 451     cidr3 = read "10.0.2.0/24"
 452     cidr4 = read "10.0.3.0/23"
 453     cidr5 = read "10.0.0.0/23"
 454     test_cidrs = [cidr1, cidr2, cidr3, cidr4, cidr5]
 455     expected = [read "10.0.0.0/22"]
 456     actual = combine_all test_cidrs
 457
 458
 459 test_combine_all2 :: TestTree
 460 test_combine_all2 =
 461   testCase desc $ actual @?= expected
 462   where
 463     desc = "127.0.0.1/32 combines with itself recursively"
 464     cidr1 = read "127.0.0.1/32"
 465     test_cidrs = [cidr1, cidr1, cidr1, cidr1, cidr1]
 466     expected = [cidr1]
 467     actual = combine_all test_cidrs
 468
 469
 470 test_combine_all3 :: TestTree
 471 test_combine_all3 =
 472   testCase desc $ actual @?= expected
 473   where
 474     desc = "10.0.0.16, 10.0.0.17, 10.0.0.18, and "
 475            ++ "10.0.0.19 get combined into 10.0.0.16/30"
 476     cidr1 = read "10.0.0.16/32"
 477     cidr2 = read "10.0.0.17/32"
 478     cidr3 = read "10.0.0.18/32"
 479     cidr4 = read "10.0.0.19/32"
 480     test_cidrs = [cidr1, cidr2, cidr3, cidr4]
 481     expected = [read "10.0.0.16/30"]
 482     actual = combine_all test_cidrs
 483
 484 -- QuickCheck Tests
 485 prop_all_cidrs_contain_themselves :: TestTree
 486 prop_all_cidrs_contain_themselves =
 487   testProperty "All CIDRs contain themselves" prop
 488   where
 489     prop :: Cidr -> Bool
 490     prop cidr1 = cidr1 `contains` cidr1
 491
 492
 493 -- If cidr1 properly contains cidr2, then by definition cidr2
 494 -- does not properly contain cidr1.
 495 prop_contains_proper_antisymmetric :: TestTree
 496 prop_contains_proper_antisymmetric =
 497   testProperty "CIDR proper containment is an antisymmetric relation" prop
 498   where
 499     prop :: Cidr -> Cidr -> Property
 500     prop cidr1 cidr2 =
 501       (cidr1 `contains_proper` cidr2) ==>
 502         (not (cidr2 `contains_proper` cidr1))