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   normalize
  20 ) where
  21
  22 import Data.List (nub)
  23 import Data.List.Split (splitOneOf)
  24 import Data.Maybe (catMaybes, mapMaybe)
  25
  26 import Test.Tasty ( TestTree, localOption, testGroup )
  27 import Test.Tasty.HUnit ( (@?=), testCase )
  28 import Test.Tasty.QuickCheck (
  29   Arbitrary( arbitrary ),
  30   Gen,
  31   Property,
  32   QuickCheckTests( QuickCheckTests ),
  33   (==>),
  34   testProperty )
  35 import Text.Read (readMaybe)
  36
  37 import qualified Bit as B (Bit(..))
  38 import IPv4Address (
  39   IPv4Address( IPv4Address, octet1, octet2, octet3, octet4 ),
  40   most_sig_bit_different )
  41 import Maskable (Maskable(apply_mask))
  42 import Maskbits ( Maskbits(Zero) )
  43 import Octet (Octet())
  44
  45
  46 data Cidr = Cidr { ipv4address :: IPv4Address,
  47                    maskbits :: Maskbits }
  48
  49
  50 instance Show Cidr where
  51     show cidr = (show (ipv4address cidr)) ++ "/" ++ (show (maskbits cidr))
  52
  53
  54 instance Arbitrary Cidr where
  55     arbitrary = do
  56       ipv4 <- arbitrary :: Gen IPv4Address
  57       mask <- arbitrary :: Gen Maskbits
  58       return (Cidr ipv4 mask)
  59
  60
  61 instance Eq Cidr where
  62   -- | Two CIDRs are equal if they have the same network bits and if
  63   --   their masks are the same. In other words, if they are the same
  64   --   after normalization.
  65   cidr1 == cidr2 = (cidr1 <= cidr2) && (cidr2 <= cidr1)
  66
  67 instance Ord Cidr where
  68   -- | The CIDR order is simply numeric, with the IPv4Address being
  69   --   considered first, before the mask. There was an arbitrary
  70   --   choice that had to be made here: which CIDR is smaller,
  71   --   127.0.0.1/8, or 127.0.0.1/32?
  72   --
  73   --   The arguments for 127.0.0.1/8 <= 127.0.0.1/32 are that it
  74   --   agrees with the numeric sort order on masks, and that it's
  75   --   generally nicer to see the big networks before the small ones.
  76   --
  77   --   On the other hand, this order disagrees with the containment
  78   --   partial order, since 127.0.0.1/32 is contained properly in
  79   --   127.0.0.1/8.
  80   --
  81   cidr1 <= cidr2 = if addr1 == addr2 then mask1 <= mask2 else addr1 <= addr2
  82     where
  83       Cidr addr1 mask1 = normalize cidr1
  84       Cidr addr2 mask2 = normalize cidr2
  85
  86 -- | Returns the mask portion of a CIDR address. That is, everything
  87 --   after the trailing slash.
  88 maskbits_from_cidr_string :: String -> Maybe Maskbits
  89 maskbits_from_cidr_string s
  90   | length partlist == 2 = readMaybe (partlist !! 1)
  91   | otherwise = Nothing
  92     where
  93       partlist = splitOneOf "/" s
  94
  95
  96 -- | Takes an IP address String in CIDR notation, and returns a list
  97 --   of its octets (as Ints).
  98 octets_from_cidr_string :: String -> [Octet]
  99 octets_from_cidr_string s =
 100   case parts of
 101     (p1:p2:p3:p4:_) -> mapMaybe readMaybe [p1,p2,p3,p4]
 102     _ -> []
 103   where
 104     parts = splitOneOf "./" s
 105
 106 instance Read Cidr where
 107   -- | Parse everything or nothing.
 108   readsPrec _ s =
 109     case (octets_from_cidr_string s) of
 110       [oct1, oct2, oct3, oct4] ->
 111         case (maskbits_from_cidr_string s) of
 112           Just mbits ->
 113             [(Cidr (IPv4Address oct1 oct2 oct3 oct4) mbits, "")]
 114           _ -> []
 115       _ -> []
 116
 117
 118 -- | Given a CIDR, return the minimum valid IPv4 address contained
 119 --   within it.
 120 min_host :: Cidr -> IPv4Address
 121 min_host (Cidr addr mask) = apply_mask addr mask B.Zero
 122
 123 -- | Given a CIDR, return the maximum valid IPv4 address contained
 124 --   within it.
 125 max_host :: Cidr -> IPv4Address
 126 max_host (Cidr addr mask) = apply_mask addr mask B.One
 127
 128 -- | Given a CIDR, return the first octet of the minimum valid IPv4
 129 --   address contained within it.
 130 min_octet1 :: Cidr -> Octet
 131 min_octet1 cidr = octet1 (min_host cidr)
 132
 133 -- | Given a CIDR, return the second octet of the minimum valid IPv4
 134 --   address contained within it.
 135 min_octet2 :: Cidr -> Octet
 136 min_octet2 cidr = octet2 (min_host cidr)
 137
 138 -- | Given a CIDR, return the third octet of the minimum valid IPv4
 139 --   address contained within it.
 140 min_octet3 :: Cidr -> Octet
 141 min_octet3 cidr = octet3 (min_host cidr)
 142
 143 -- | Given a CIDR, return the fourth octet of the minimum valid IPv4
 144 --   address contained within it.
 145 min_octet4 :: Cidr -> Octet
 146 min_octet4 cidr = octet4 (min_host cidr)
 147
 148 -- | Given a CIDR, return the first octet of the maximum valid IPv4
 149 --   address contained within it.
 150 max_octet1 :: Cidr -> Octet
 151 max_octet1 cidr = octet1 (max_host cidr)
 152
 153 -- | Given a CIDR, return the second octet of the maximum valid IPv4
 154 --   address contained within it.
 155 max_octet2 :: Cidr -> Octet
 156 max_octet2 cidr = octet2 (max_host cidr)
 157
 158 -- | Given a CIDR, return the third octet of the maximum valid IPv4
 159 --   address contained within it.
 160 max_octet3 :: Cidr -> Octet
 161 max_octet3 cidr = octet3 (max_host cidr)
 162
 163 -- | Given a CIDR, return the fourth octet of the maximum valid IPv4
 164 --   address contained within it.
 165 max_octet4 :: Cidr -> Octet
 166 max_octet4 cidr = octet4 (max_host cidr)
 167
 168
 169
 170 -- | Return true if the first argument (a CIDR range) contains the
 171 --   second (another CIDR range). There are a lot of ways we can be
 172 --   fed junk here. For lack of a better alternative, just return
 173 --   False when we are given nonsense.
 174 --
 175 --   If the number of bits in the network part of the first address is
 176 --   larger than the number of bits in the second, there is no way
 177 --   that the first range can contain the second. For, if the number
 178 --   of network bits is larger, then the number of host bits must be
 179 --   smaller, and if cidr1 has fewer hosts than cidr2, cidr1 most
 180 --   certainly does not contain cidr2.
 181 --
 182 --   On the other hand, if the first argument (cidr1) has fewer (or
 183 --   the same number of) network bits as the second, it can contain
 184 --   the second. In this case, we need to check that every host in
 185 --   cidr2 is contained in cidr1. If a host in cidr2 is contained in
 186 --   cidr1, then at least mbits1 of an address in cidr2 will match
 187 --   cidr1. For example,
 188 --
 189 --   cidr1 = 192.168.1.0\/23, cidr2 = 192.168.1.100\/24
 190 --
 191 --   Here, cidr2 contains all of 192.168.1.0 through
 192 --   192.168.1.255. However, cidr1 contains BOTH 192.168.0.0 through
 193 --   192.168.0.255 and 192.168.1.0 through 192.168.1.255. In essence,
 194 --   what we want to check is that cidr2 "begins with" something that
 195 --   cidr1 CAN begin with. Since cidr1 can begin with 192.168.1, and
 196 --   cidr2 DOES, cidr1 contains cidr2..
 197 --
 198 --   The way that we check this is to apply cidr1's mask to cidr2's
 199 --   address and see if the result is the same as cidr1's mask applied
 200 --   to cidr1's address.
 201 --
 202 contains :: Cidr -> Cidr -> Bool
 203 contains (Cidr addr1 mbits1) (Cidr addr2 mbits2)
 204   | mbits1 > mbits2 = False
 205   | otherwise = addr1masked == addr2masked
 206   where
 207     addr1masked = apply_mask addr1 mbits1 B.Zero
 208     addr2masked = apply_mask addr2 mbits1 B.Zero
 209
 210
 211 -- | Contains but is not equal to.
 212 contains_proper :: Cidr -> Cidr -> Bool
 213 contains_proper cidr1 cidr2 =
 214     (cidr1 `contains` cidr2) && (not (cidr2 `contains` cidr1))
 215
 216
 217 -- | A CIDR range is redundant (with respect to the given list) if
 218 --   another CIDR range in that list properly contains it.
 219 redundant :: [Cidr] -> Cidr -> Bool
 220 redundant cidrlist cidr = any ((flip contains_proper) cidr) cidrlist
 221
 222
 223 -- | First, we look at all possible pairs of cidrs, and combine the
 224 --   adjacent ones in to a new list. Then, we concatenate that list
 225 --   with the original one, and filter out all of the redundancies. If
 226 --   two adjacent Cidrs are combined into a larger one, they will be
 227 --   removed in the second step since the larger Cidr must contain the
 228 --   smaller two.
 229 --
 230 --   Once this is done, we see whether or not the result is different
 231 --   than the argument that was passed in. If nothing changed, we're
 232 --   done and return the list that was passed to us. However, if
 233 --   something changed, we recurse and try to combine the list again.
 234 combine_all :: [Cidr] -> [Cidr]
 235 combine_all cidrs
 236   | cidrs == (combine_contained unique_cidrs) = cidrs
 237   | otherwise = combine_all (combine_contained unique_cidrs)
 238     where
 239       unique_cidrs = nub cidr_combinations
 240       cidr_combinations =
 241         cidrs ++ (catMaybes [ (combine_adjacent x y) | x <- cidrs, y <- cidrs ])
 242
 243
 244 -- | Take a list of CIDR ranges and filter out all of the ones that
 245 --   are contained entirelt within some other range in the list.
 246 combine_contained :: [Cidr] -> [Cidr]
 247 combine_contained cidrs =
 248   filter (not . (redundant cidrs)) cidrs
 249
 250
 251 -- | If the two Cidrs are not adjacent, return Cidr.None. Otherwise,
 252 --   decrement the maskbits of cidr1 and return that; it will contain
 253 --   both cidr1 and cidr2.
 254 combine_adjacent :: Cidr -> Cidr -> Maybe Cidr
 255 combine_adjacent cidr1 cidr2
 256   | not (adjacent cidr1 cidr2) = Nothing
 257   | (maskbits cidr1 == Zero) = Nothing
 258   | otherwise = Just $ cidr1 { maskbits = pred (maskbits cidr1) }
 259
 260
 261
 262 -- | Determine whether or not two CIDR ranges are adjacent. If two
 263 --   ranges lie consecutively within the IP space, they can be
 264 --   combined. For example, 10.1.0.0/24 and 10.0.1.0/24 are adjacent,
 265 --   and can be combined in to 10.1.0.0/23.
 266 adjacent :: Cidr -> Cidr -> Bool
 267 adjacent cidr1 cidr2
 268   | mbits1 /= mbits2 = False
 269   | mbits1 == Maskbits.Zero = False -- They're equal.
 270   | otherwise = (mbits1 == (most_sig_bit_different addr1 addr2))
 271   where
 272     addr1 = ipv4address cidr1
 273     addr2 = ipv4address cidr2
 274     mbits1 = maskbits cidr1
 275     mbits2 = maskbits cidr2
 276
 277
 278 enumerate :: Cidr -> [IPv4Address]
 279 enumerate cidr = [(min_host cidr)..(max_host cidr)]
 280
 281
 282 -- | Replace any masked bits in this CIDR's IPv4Address with zeros.
 283 normalize :: Cidr -> Cidr
 284 normalize (Cidr addr mask) =
 285   Cidr nrml_addr mask
 286   where
 287     nrml_addr = apply_mask addr mask B.Zero
 288
 289 -- Test lists.
 290 cidr_tests :: TestTree
 291 cidr_tests =
 292   testGroup "CIDR Tests" [
 293     test_enumerate,
 294     test_min_host1,
 295     test_max_host1,
 296     test_equality1,
 297     test_contains1,
 298     test_contains2,
 299     test_contains_proper1,
 300     test_contains_proper2,
 301     test_adjacent1,
 302     test_adjacent2,
 303     test_adjacent3,
 304     test_adjacent4,
 305     test_combine_contained1,
 306     test_combine_contained2,
 307     test_combine_all1,
 308     test_combine_all2,
 309     test_combine_all3,
 310     test_normalize1,
 311     test_normalize2,
 312     test_normalize3,
 313     test_big_networks_come_first ]
 314
 315 cidr_properties :: TestTree
 316 cidr_properties =
 317   testGroup "CIDR Properties" [
 318       prop_all_cidrs_contain_themselves,
 319       prop_contains_proper_antisymmetric,
 320       prop_normalize_idempotent,
 321       prop_normalize_preserves_equality,
 322       prop_ord_instance_antisymmetric,
 323       prop_ord_instance_reflexive,
 324       prop_ord_instance_transitive,
 325       prop_ord_uses_addr_when_masks_equal,
 326       prop_ord_uses_mask_when_addrs_equal,
 327       prop_ord_and_contains_disagree,
 328       prop_ord_minimum,
 329       prop_ord_maximum ]
 330
 331
 332 -- HUnit Tests
 333 test_enumerate :: TestTree
 334 test_enumerate =
 335   testCase desc $ actual @?= expected
 336   where
 337     desc = "192.168.0.240/30 is enumerated correctly"
 338     oct1 = toEnum 192 :: Octet
 339     oct2 = toEnum 168 :: Octet
 340     oct3 = minBound :: Octet
 341     mk_ip = IPv4Address oct1 oct2 oct3
 342     addr1 = mk_ip $ toEnum 240
 343     addr2 = mk_ip $ toEnum 241
 344     addr3 = mk_ip $ toEnum 242
 345     addr4 = mk_ip $ toEnum 243
 346     expected = [addr1, addr2, addr3, addr4]
 347     actual = enumerate (read "192.168.0.240/30" :: Cidr)
 348
 349 test_min_host1 :: TestTree
 350 test_min_host1 =
 351   testCase desc $ actual @?= expected
 352   where
 353     desc = "The minimum host in 10.0.0.0/24 is 10.0.0.0"
 354     actual = show $ min_host (read "10.0.0.0/24" :: Cidr)
 355     expected = "10.0.0.0"
 356
 357
 358 test_max_host1 :: TestTree
 359 test_max_host1 =
 360   testCase desc $ actual @?= expected
 361   where
 362     desc = "The maximum host in 10.0.0.0/24 is 10.0.0.255"
 363     actual = show $ max_host (read "10.0.0.0/24" :: Cidr)
 364     expected = "10.0.0.255"
 365
 366
 367 test_equality1 :: TestTree
 368 test_equality1 =
 369   testCase desc $ actual @?= expected
 370   where
 371     desc = "10.1.1.0/23 equals itself"
 372     actual = read "10.1.1.0/23" :: Cidr
 373     expected = read "10.1.1.0/23" :: Cidr
 374
 375
 376 test_contains1 :: TestTree
 377 test_contains1 =
 378   testCase desc $ actual @?= expected
 379   where
 380     desc = "10.1.1.0/23 contains 10.1.1.0/24"
 381     cidr1 = read "10.1.1.0/23" :: Cidr
 382     cidr2 = read "10.1.1.0/24" :: Cidr
 383     expected = True
 384     actual = cidr1 `contains` cidr2
 385
 386
 387 test_contains2 :: TestTree
 388 test_contains2 =
 389   testCase desc $ actual @?= expected
 390   where
 391     desc = "10.1.1.0/23 contains itself"
 392     cidr1 = read "10.1.1.0/23" :: Cidr
 393     expected = True
 394     actual = cidr1 `contains` cidr1
 395
 396
 397 test_contains_proper1 :: TestTree
 398 test_contains_proper1 =
 399   testCase desc $ actual @?= expected
 400   where
 401     desc = "10.1.1.0/23 contains 10.1.1.0/24 properly"
 402     cidr1 = read "10.1.1.0/23" :: Cidr
 403     cidr2 = read "10.1.1.0/24" :: Cidr
 404     expected = True
 405     actual = cidr1 `contains_proper` cidr2
 406
 407
 408 test_contains_proper2 :: TestTree
 409 test_contains_proper2 =
 410   testCase desc $ actual @?= expected
 411   where
 412     desc = "10.1.1.0/23 does not contain itself properly"
 413     cidr1 = read "10.1.1.0/23" :: Cidr
 414     expected = False
 415     actual = cidr1 `contains_proper` cidr1
 416
 417
 418 test_adjacent1 :: TestTree
 419 test_adjacent1 =
 420   testCase desc $ actual @?= expected
 421   where
 422     desc = "10.1.0.0/24 is adjacent to 10.1.1.0/24"
 423     cidr1 = read "10.1.0.0/24" :: Cidr
 424     cidr2 = read "10.1.1.0/24" :: Cidr
 425     expected = True
 426     actual = cidr1 `adjacent` cidr2
 427
 428
 429 test_adjacent2 :: TestTree
 430 test_adjacent2 =
 431   testCase desc $ actual @?= expected
 432   where
 433     desc = "10.1.0.0/23 is not adjacent to 10.1.0.0/24"
 434     cidr1 = read "10.1.0.0/23" :: Cidr
 435     cidr2 = read "10.1.0.0/24" :: Cidr
 436     expected = False
 437     actual = cidr1 `adjacent` cidr2
 438
 439
 440 test_adjacent3 :: TestTree
 441 test_adjacent3 =
 442   testCase desc $ actual @?= expected
 443   where
 444     desc = "10.1.0.0/24 is not adjacent to 10.2.5.0/24"
 445     cidr1 = read "10.1.0.0/24" :: Cidr
 446     cidr2 = read "10.2.5.0/24" :: Cidr
 447     expected = False
 448     actual = cidr1 `adjacent` cidr2
 449
 450
 451 test_adjacent4 :: TestTree
 452 test_adjacent4 =
 453   testCase desc $ actual @?= expected
 454   where
 455     desc = "10.1.1.0/24 is not adjacent to 10.1.2.0/24"
 456     cidr1 = read "10.1.1.0/24" :: Cidr
 457     cidr2 = read "10.1.2.0/24" :: Cidr
 458     expected = False
 459     actual = cidr1 `adjacent` cidr2
 460
 461 test_combine_contained1 :: TestTree
 462 test_combine_contained1 =
 463   testCase desc $ actual @?= expected
 464   where
 465     desc = "10.0.0.0/8, 10.1.0.0/16, and 10.1.1.0/24 combine to 10.0.0.0/8"
 466     cidr1 = read "10.0.0.0/8" :: Cidr
 467     cidr2 = read "10.1.0.0/16" :: Cidr
 468     cidr3 = read "10.1.1.0/24" :: Cidr
 469     test_cidrs = [cidr1, cidr2, cidr3]
 470     expected = [cidr1]
 471     actual = combine_contained test_cidrs
 472
 473 test_combine_contained2 :: TestTree
 474 test_combine_contained2 =
 475   testCase desc $ actual @?= expected
 476   where
 477     desc = "192.168.3.0/23 does not contain 192.168.1.0/24"
 478     cidr1 = read "192.168.3.0/23" :: Cidr
 479     cidr2 = read "192.168.1.0/24" :: Cidr
 480     expected = [cidr1, cidr2]
 481     actual = combine_contained [cidr1, cidr2]
 482
 483
 484 test_combine_all1 :: TestTree
 485 test_combine_all1 =
 486   testCase desc $ actual @?= expected
 487   where
 488     desc = "10.0.0.0/24 is adjacent to 10.0.1.0/24 "
 489            ++ "and 10.0.3.0/23 contains 10.0.2.0/24"
 490     cidr1 = read "10.0.0.0/24" :: Cidr
 491     cidr2 = read "10.0.1.0/24" :: Cidr
 492     cidr3 = read "10.0.2.0/24" :: Cidr
 493     cidr4 = read "10.0.3.0/23" :: Cidr
 494     cidr5 = read "10.0.0.0/23" :: Cidr
 495     test_cidrs = [cidr1, cidr2, cidr3, cidr4, cidr5]
 496     expected = [read "10.0.0.0/22" :: Cidr]
 497     actual = combine_all test_cidrs
 498
 499
 500 test_combine_all2 :: TestTree
 501 test_combine_all2 =
 502   testCase desc $ actual @?= expected
 503   where
 504     desc = "127.0.0.1/32 combines with itself recursively"
 505     cidr1 = read "127.0.0.1/32" :: Cidr
 506     test_cidrs = [cidr1, cidr1, cidr1, cidr1, cidr1]
 507     expected = [cidr1]
 508     actual = combine_all test_cidrs
 509
 510
 511 test_combine_all3 :: TestTree
 512 test_combine_all3 =
 513   testCase desc $ actual @?= expected
 514   where
 515     desc = "10.0.0.16, 10.0.0.17, 10.0.0.18, and "
 516            ++ "10.0.0.19 get combined into 10.0.0.16/30"
 517     cidr1 = read "10.0.0.16/32" :: Cidr
 518     cidr2 = read "10.0.0.17/32" :: Cidr
 519     cidr3 = read "10.0.0.18/32" :: Cidr
 520     cidr4 = read "10.0.0.19/32" :: Cidr
 521     test_cidrs = [cidr1, cidr2, cidr3, cidr4]
 522     expected = [read "10.0.0.16/30" :: Cidr]
 523     actual = combine_all test_cidrs
 524
 525 test_normalize1 :: TestTree
 526 test_normalize1 =
 527   testCase desc $ actual @?= expected
 528   where
 529     desc = "127.0.0.1/8 normalized is 127.0.0.0/8"
 530     expected = read "127.0.0.0/8" :: Cidr
 531     actual = normalize (read "127.0.0.1/8" :: Cidr)
 532
 533
 534 test_normalize2 :: TestTree
 535 test_normalize2 =
 536   testCase desc $ actual @?= expected
 537   where
 538     desc = "192.168.1.101/24 normalized is 192.168.1.0/24"
 539     expected = read "192.168.1.0/24" :: Cidr
 540     actual = normalize (read "192.168.1.101/24" :: Cidr)
 541
 542 test_normalize3 :: TestTree
 543 test_normalize3 =
 544   testCase desc $ actual @?= expected
 545   where
 546     desc = "10.10.10.10/22 normalized is 10.10.8.0/22"
 547     expected = read "10.10.8.0/22" :: Cidr
 548     actual = normalize (read "10.10.10.10/22" :: Cidr)
 549
 550 -- | Test a stated property of the Ord instance, namely that the big
 551 --   network 127.0.0.1/8 comes before the small network 127.0.0.1/32.
 552 test_big_networks_come_first :: TestTree
 553 test_big_networks_come_first =
 554   testCase desc $ actual @?= expected
 555   where
 556     desc = "127.0.0.1/8 comes before 127.0.0.1/32"
 557     big = read "127.0.0.1/8" :: Cidr
 558     small = read "127.0.0.1/32" :: Cidr
 559     expected = True
 560     actual = big <= small -- not a typo
 561
 562 -- QuickCheck Tests
 563 prop_all_cidrs_contain_themselves :: TestTree
 564 prop_all_cidrs_contain_themselves =
 565   testProperty "All CIDRs contain themselves" prop
 566   where
 567     prop :: Cidr -> Bool
 568     prop cidr1 = cidr1 `contains` cidr1
 569
 570
 571 -- If cidr1 properly contains cidr2, then by definition cidr2
 572 -- does not properly contain cidr1.
 573 prop_contains_proper_antisymmetric :: TestTree
 574 prop_contains_proper_antisymmetric =
 575   testProperty "CIDR proper containment is an antisymmetric relation" prop
 576   where
 577     prop :: Cidr -> Cidr -> Property
 578     prop cidr1 cidr2 =
 579       (cidr1 `contains_proper` cidr2) ==>
 580         (not (cidr2 `contains_proper` cidr1))
 581
 582
 583 -- Running "normalize" a second time shouldn't do anything.
 584 prop_normalize_idempotent :: TestTree
 585 prop_normalize_idempotent =
 586   testProperty "The CIDR \"normalize\" function is idempotent" prop
 587   where
 588     prop :: Cidr -> Bool
 589     prop cidr = (normalize cidr) == (normalize (normalize cidr))
 590
 591 -- Normalization should not affect equality of two CIDRs.
 592 prop_normalize_preserves_equality :: TestTree
 593 prop_normalize_preserves_equality =
 594   testProperty "The CIDR \"normalize\" function preserves equality" prop
 595   where
 596     prop :: Cidr -> Cidr -> Bool
 597     prop cidr1 cidr2 = (cidr1 == cidr2) == (normalize cidr1 == normalize cidr2)
 598
 599
 600 prop_ord_instance_reflexive :: TestTree
 601 prop_ord_instance_reflexive =
 602   testProperty "The CIDR order is reflexive" prop
 603   where
 604     prop :: Cidr -> Bool
 605     prop cidr = cidr <= cidr
 606
 607
 608 prop_ord_instance_transitive :: TestTree
 609 prop_ord_instance_transitive =
 610   testProperty "The CIDR order is transitive" prop
 611   where
 612     prop :: Cidr -> Cidr -> Cidr -> Property
 613     prop cidr1 cidr2 cidr3 =
 614       (cidr1 <= cidr2 && cidr2 <= cidr3) ==> cidr1 <= cidr3
 615
 616 -- This is how Eq is currently implemented, but it is useful to have
 617 -- around in case that changes. Try fewer instances of this than usual
 618 -- because it's a rare condition.
 619 prop_ord_instance_antisymmetric :: TestTree
 620 prop_ord_instance_antisymmetric =
 621   localOption (QuickCheckTests 500) $
 622     testProperty "The CIDR order is antisymmetric" prop
 623   where
 624     prop :: Cidr -> Cidr -> Property
 625     prop cidr1 cidr2 =
 626       (cidr1 <= cidr2 && cidr2 <= cidr1) ==> cidr1 == cidr2
 627
 628
 629 -- When comparing two CIDRs with the same mask, the comparison
 630 -- should be numeric (i.e. whatever the IPv4Address does).
 631 -- Of course, we have to normalize first.
 632 prop_ord_uses_addr_when_masks_equal :: TestTree
 633 prop_ord_uses_addr_when_masks_equal =
 634   testProperty "The CIDR order is the IPv4Address order for equal masks" prop
 635   where
 636     prop :: Cidr -> Cidr -> Property
 637     prop cidr1 cidr2 =
 638       (mask1 == mask2) ==> (cidr1 <= cidr2) == (addr1 <= addr2)
 639       where
 640         (Cidr addr1 mask1) = normalize cidr1
 641         (Cidr addr2 mask2) = normalize cidr2
 642
 643
 644 -- If we have two CIDRs whose normalized addresses agree, then we want
 645 -- to use the mask order, i.e. that big networks come before small
 646 -- networks. This disagrees with containment order.
 647 prop_ord_uses_mask_when_addrs_equal :: TestTree
 648 prop_ord_uses_mask_when_addrs_equal =
 649   localOption (QuickCheckTests 500) $
 650     testProperty "The CIDR order is by mask when the addresses agree" prop
 651   where
 652     prop :: Cidr -> Cidr -> Property
 653     prop cidr1 cidr2 =
 654       (addr1 == addr2) ==> (cidr1 <= cidr2) == (mask1 <= mask2)
 655       where
 656         (Cidr addr1 mask1) = normalize cidr1
 657         (Cidr addr2 mask2) = normalize cidr2
 658
 659
 660 -- Big networks come first.
 661 prop_ord_and_contains_disagree :: TestTree
 662 prop_ord_and_contains_disagree =
 663   testProperty "The CIDR order disagrees with containment" prop
 664   where
 665     prop :: Cidr -> Cidr -> Property
 666     prop cidr1 cidr2 = (cidr1 `contains` cidr2) ==> (cidr1 <= cidr2)
 667
 668
 669 -- The biggest network always comes first.
 670 prop_ord_minimum :: TestTree
 671 prop_ord_minimum =
 672   testProperty "The CIDR order has 0.0.0.0/0 as a minimum" prop
 673   where
 674     min_cidr = read "0.0.0.0/0" :: Cidr
 675     prop :: Cidr -> Bool
 676     prop cidr = min_cidr <= cidr
 677
 678
 679 -- The CIDR order also has a maximum.
 680 prop_ord_maximum :: TestTree
 681 prop_ord_maximum =
 682   testProperty "The CIDR order has 255.255.255.255/32 as a maximum" prop
 683   where
 684     max_cidr = read "255.255.255.255/32" :: Cidr
 685     prop :: Cidr -> Bool
 686     prop cidr = max_cidr >= cidr