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