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