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
 308
 309 -- HUnit Tests
 310 test_enumerate :: TestTree
 311 test_enumerate =
 312   testCase desc $ actual @?= expected
 313   where
 314     desc = "192.168.0.240/30 is enumerated correctly"
 315     oct1 = toEnum 192 :: Octet
 316     oct2 = toEnum 168 :: Octet
 317     oct3 = minBound :: Octet
 318     mk_ip = IPv4Address oct1 oct2 oct3
 319     addr1 = mk_ip $ toEnum 240
 320     addr2 = mk_ip $ toEnum 241
 321     addr3 = mk_ip $ toEnum 242
 322     addr4 = mk_ip $ toEnum 243
 323     expected = [addr1, addr2, addr3, addr4]
 324     actual = enumerate (read "192.168.0.240/30" :: Cidr)
 325
 326 test_min_host1 :: TestTree
 327 test_min_host1 =
 328   testCase desc $ actual @?= expected
 329   where
 330     desc = "The minimum host in 10.0.0.0/24 is 10.0.0.0"
 331     actual = show $ min_host (read "10.0.0.0/24" :: Cidr)
 332     expected = "10.0.0.0"
 333
 334
 335 test_max_host1 :: TestTree
 336 test_max_host1 =
 337   testCase desc $ actual @?= expected
 338   where
 339     desc = "The maximum host in 10.0.0.0/24 is 10.0.0.255"
 340     actual = show $ max_host (read "10.0.0.0/24" :: Cidr)
 341     expected = "10.0.0.255"
 342
 343
 344 test_equality1 :: TestTree
 345 test_equality1 =
 346   testCase desc $ actual @?= expected
 347   where
 348     desc = "10.1.1.0/23 equals itself"
 349     actual = read "10.1.1.0/23" :: Cidr
 350     expected = read "10.1.1.0/23" :: Cidr
 351
 352
 353 test_contains1 :: TestTree
 354 test_contains1 =
 355   testCase desc $ actual @?= expected
 356   where
 357     desc = "10.1.1.0/23 contains 10.1.1.0/24"
 358     cidr1 = read "10.1.1.0/23" :: Cidr
 359     cidr2 = read "10.1.1.0/24" :: Cidr
 360     expected = True
 361     actual = cidr1 `contains` cidr2
 362
 363
 364 test_contains2 :: TestTree
 365 test_contains2 =
 366   testCase desc $ actual @?= expected
 367   where
 368     desc = "10.1.1.0/23 contains itself"
 369     cidr1 = read "10.1.1.0/23" :: Cidr
 370     expected = True
 371     actual = cidr1 `contains` cidr1
 372
 373
 374 test_contains_proper1 :: TestTree
 375 test_contains_proper1 =
 376   testCase desc $ actual @?= expected
 377   where
 378     desc = "10.1.1.0/23 contains 10.1.1.0/24 properly"
 379     cidr1 = read "10.1.1.0/23" :: Cidr
 380     cidr2 = read "10.1.1.0/24" :: Cidr
 381     expected = True
 382     actual = cidr1 `contains_proper` cidr2
 383
 384
 385 test_contains_proper2 :: TestTree
 386 test_contains_proper2 =
 387   testCase desc $ actual @?= expected
 388   where
 389     desc = "10.1.1.0/23 does not contain itself properly"
 390     cidr1 = read "10.1.1.0/23" :: Cidr
 391     expected = False
 392     actual = cidr1 `contains_proper` cidr1
 393
 394
 395 test_adjacent1 :: TestTree
 396 test_adjacent1 =
 397   testCase desc $ actual @?= expected
 398   where
 399     desc = "10.1.0.0/24 is adjacent to 10.1.1.0/24"
 400     cidr1 = read "10.1.0.0/24" :: Cidr
 401     cidr2 = read "10.1.1.0/24" :: Cidr
 402     expected = True
 403     actual = cidr1 `adjacent` cidr2
 404
 405
 406 test_adjacent2 :: TestTree
 407 test_adjacent2 =
 408   testCase desc $ actual @?= expected
 409   where
 410     desc = "10.1.0.0/23 is not adjacent to 10.1.0.0/24"
 411     cidr1 = read "10.1.0.0/23" :: Cidr
 412     cidr2 = read "10.1.0.0/24" :: Cidr
 413     expected = False
 414     actual = cidr1 `adjacent` cidr2
 415
 416
 417 test_adjacent3 :: TestTree
 418 test_adjacent3 =
 419   testCase desc $ actual @?= expected
 420   where
 421     desc = "10.1.0.0/24 is not adjacent to 10.2.5.0/24"
 422     cidr1 = read "10.1.0.0/24" :: Cidr
 423     cidr2 = read "10.2.5.0/24" :: Cidr
 424     expected = False
 425     actual = cidr1 `adjacent` cidr2
 426
 427
 428 test_adjacent4 :: TestTree
 429 test_adjacent4 =
 430   testCase desc $ actual @?= expected
 431   where
 432     desc = "10.1.1.0/24 is not adjacent to 10.1.2.0/24"
 433     cidr1 = read "10.1.1.0/24" :: Cidr
 434     cidr2 = read "10.1.2.0/24" :: Cidr
 435     expected = False
 436     actual = cidr1 `adjacent` cidr2
 437
 438 test_combine_contained1 :: TestTree
 439 test_combine_contained1 =
 440   testCase desc $ actual @?= expected
 441   where
 442     desc = "10.0.0.0/8, 10.1.0.0/16, and 10.1.1.0/24 combine to 10.0.0.0/8"
 443     cidr1 = read "10.0.0.0/8" :: Cidr
 444     cidr2 = read "10.1.0.0/16" :: Cidr
 445     cidr3 = read "10.1.1.0/24" :: Cidr
 446     test_cidrs = [cidr1, cidr2, cidr3]
 447     expected = [cidr1]
 448     actual = combine_contained test_cidrs
 449
 450 test_combine_contained2 :: TestTree
 451 test_combine_contained2 =
 452   testCase desc $ actual @?= expected
 453   where
 454     desc = "192.168.3.0/23 does not contain 192.168.1.0/24"
 455     cidr1 = read "192.168.3.0/23" :: Cidr
 456     cidr2 = read "192.168.1.0/24" :: Cidr
 457     expected = [cidr1, cidr2]
 458     actual = combine_contained [cidr1, cidr2]
 459
 460
 461 test_combine_all1 :: TestTree
 462 test_combine_all1 =
 463   testCase desc $ actual @?= expected
 464   where
 465     desc = "10.0.0.0/24 is adjacent to 10.0.1.0/24 "
 466            ++ "and 10.0.3.0/23 contains 10.0.2.0/24"
 467     cidr1 = read "10.0.0.0/24" :: Cidr
 468     cidr2 = read "10.0.1.0/24" :: Cidr
 469     cidr3 = read "10.0.2.0/24" :: Cidr
 470     cidr4 = read "10.0.3.0/23" :: Cidr
 471     cidr5 = read "10.0.0.0/23" :: Cidr
 472     test_cidrs = [cidr1, cidr2, cidr3, cidr4, cidr5]
 473     expected = [read "10.0.0.0/22" :: Cidr]
 474     actual = combine_all test_cidrs
 475
 476
 477 test_combine_all2 :: TestTree
 478 test_combine_all2 =
 479   testCase desc $ actual @?= expected
 480   where
 481     desc = "127.0.0.1/32 combines with itself recursively"
 482     cidr1 = read "127.0.0.1/32" :: Cidr
 483     test_cidrs = [cidr1, cidr1, cidr1, cidr1, cidr1]
 484     expected = [cidr1]
 485     actual = combine_all test_cidrs
 486
 487
 488 test_combine_all3 :: TestTree
 489 test_combine_all3 =
 490   testCase desc $ actual @?= expected
 491   where
 492     desc = "10.0.0.16, 10.0.0.17, 10.0.0.18, and "
 493            ++ "10.0.0.19 get combined into 10.0.0.16/30"
 494     cidr1 = read "10.0.0.16/32" :: Cidr
 495     cidr2 = read "10.0.0.17/32" :: Cidr
 496     cidr3 = read "10.0.0.18/32" :: Cidr
 497     cidr4 = read "10.0.0.19/32" :: Cidr
 498     test_cidrs = [cidr1, cidr2, cidr3, cidr4]
 499     expected = [read "10.0.0.16/30" :: Cidr]
 500     actual = combine_all test_cidrs
 501
 502 test_normalize1 :: TestTree
 503 test_normalize1 =
 504   testCase desc $ actual @?= expected
 505   where
 506     desc = "127.0.0.1/8 normalized is 127.0.0.0/8"
 507     expected = read "127.0.0.0/8" :: Cidr
 508     actual = normalize (read "127.0.0.1/8" :: Cidr)
 509
 510
 511 test_normalize2 :: TestTree
 512 test_normalize2 =
 513   testCase desc $ actual @?= expected
 514   where
 515     desc = "192.168.1.101/24 normalized is 192.168.1.0/24"
 516     expected = read "192.168.1.0/24" :: Cidr
 517     actual = normalize (read "192.168.1.101/24" :: Cidr)
 518
 519 test_normalize3 :: TestTree
 520 test_normalize3 =
 521   testCase desc $ actual @?= expected
 522   where
 523     desc = "10.10.10.10/22 normalized is 10.10.8.0/22"
 524     expected = read "10.10.8.0/22" :: Cidr
 525     actual = normalize (read "10.10.10.10/22" :: Cidr)
 526
 527 -- QuickCheck Tests
 528 prop_all_cidrs_contain_themselves :: TestTree
 529 prop_all_cidrs_contain_themselves =
 530   testProperty "All CIDRs contain themselves" prop
 531   where
 532     prop :: Cidr -> Bool
 533     prop cidr1 = cidr1 `contains` cidr1
 534
 535
 536 -- If cidr1 properly contains cidr2, then by definition cidr2
 537 -- does not properly contain cidr1.
 538 prop_contains_proper_antisymmetric :: TestTree
 539 prop_contains_proper_antisymmetric =
 540   testProperty "CIDR proper containment is an antisymmetric relation" prop
 541   where
 542     prop :: Cidr -> Cidr -> Property
 543     prop cidr1 cidr2 =
 544       (cidr1 `contains_proper` cidr2) ==>
 545         (not (cidr2 `contains_proper` cidr1))
 546
 547
 548 -- Running "normalize" a second time shouldn't do anything.
 549 prop_normalize_idempotent :: TestTree
 550 prop_normalize_idempotent =
 551   testProperty "The CIDR \"normalize\" function is idempotent " prop
 552   where
 553     prop :: Cidr -> Bool
 554     prop cidr = (normalize cidr) == (normalize (normalize cidr))
 555
 556 -- Normalization should not affect equality of two CIDRs.
 557 prop_normalize_preserves_equality :: TestTree
 558 prop_normalize_preserves_equality =
 559   testProperty "The CIDR \"normalize\" function preserves equality " prop
 560   where
 561     prop :: Cidr -> Cidr -> Bool
 562     prop cidr1 cidr2 = (cidr1 == cidr2) == (normalize cidr1 == normalize cidr2)