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