src/IPv4Address.hs

   1 module IPv4Address(
   2   IPv4Address(..),
   3   ipv4address_properties,
   4   ipv4address_tests,
   5   most_sig_bit_different )
   6 where
   7
   8 import Data.Int ( Int32, Int64 )
   9 import Data.Word ( Word32 )
  10
  11 import Test.Tasty ( TestTree, testGroup )
  12 import Test.Tasty.HUnit ( (@?=), testCase )
  13 import Test.Tasty.QuickCheck (
  14   Arbitrary( arbitrary ),
  15   Gen,
  16   Large,
  17   Property,
  18   Small,
  19   (==>),
  20   testProperty )
  21
  22 import Maskable ( Maskable( apply_mask) )
  23 import Maskbits (
  24   Maskbits(
  25     Zero, One, Two, Three, Four, Five, Six, Seven, Eight,
  26     Nine, Ten, Eleven, Twelve, Thirteen, Fourteen, Fifteen, Sixteen,
  27     Seventeen, Eighteen, Nineteen, Twenty, TwentyOne, TwentyTwo, TwentyThree,
  28     TwentyFour, TwentyFive, TwentySix, TwentySeven, TwentyEight, TwentyNine,
  29     Thirty, ThirtyOne, ThirtyTwo ) )
  30 import Octet ( Octet( b1, b2, b3, b4, b5, b6, b7, b8) )
  31
  32 data IPv4Address =
  33   IPv4Address { octet1 :: Octet,
  34                 octet2 :: Octet,
  35                 octet3 :: Octet,
  36                 octet4 :: Octet }
  37     deriving (Eq, Ord)
  38
  39
  40 instance Show IPv4Address where
  41   show addr = concat [(show oct1) ++ ".",
  42                       (show oct2) ++ ".",
  43                       (show oct3) ++ ".",
  44                       (show oct4)]
  45       where
  46         oct1 = (octet1 addr)
  47         oct2 = (octet2 addr)
  48         oct3 = (octet3 addr)
  49         oct4 = (octet4 addr)
  50
  51
  52 instance Arbitrary IPv4Address where
  53   arbitrary = do
  54     oct1 <- arbitrary :: Gen Octet
  55     oct2 <- arbitrary :: Gen Octet
  56     oct3 <- arbitrary :: Gen Octet
  57     oct4 <- arbitrary :: Gen Octet
  58     return (IPv4Address oct1 oct2 oct3 oct4)
  59
  60
  61
  62 instance Maskable IPv4Address where
  63
  64   apply_mask addr mask bit =
  65    apply_mask' mask
  66    where
  67      oct1 = octet1 addr
  68      oct2 = octet2 addr
  69      oct3 = octet3 addr
  70      oct4 = octet4 addr
  71
  72      -- A copy of 'addr' with the fourth octet zeroed (or oned).
  73      new_addr1 = addr { octet4 = (apply_mask oct4 Zero bit) }
  74
  75      -- Likewise for new_addr1's third octet.
  76      new_addr2 = new_addr1 { octet3 = (apply_mask oct3 Zero bit) }
  77
  78      -- And new_addr2's second octet.
  79      new_addr3 = new_addr2 { octet2 = (apply_mask oct2 Zero bit) }
  80
  81      -- This helper function allows us to pattern-match cleanly.
  82      apply_mask' :: Maskbits -> IPv4Address
  83
  84      apply_mask' ThirtyTwo = addr
  85
  86      apply_mask' ThirtyOne = addr { octet4 = (apply_mask oct4 Seven bit) }
  87
  88      apply_mask' Thirty =
  89        addr { octet4 = (apply_mask oct4 Six bit) }
  90
  91      apply_mask' TwentyNine =
  92        addr { octet4 = (apply_mask oct4 Five bit) }
  93
  94      apply_mask' TwentyEight =
  95        addr { octet4 = (apply_mask oct4 Four bit) }
  96
  97      apply_mask' TwentySeven =
  98        addr { octet4 = (apply_mask oct4 Three bit) }
  99
 100      apply_mask' TwentySix =
 101        addr { octet4 = (apply_mask oct4 Two bit) }
 102
 103      apply_mask' TwentyFive =
 104        addr { octet4 = (apply_mask oct4 One bit) }
 105
 106      apply_mask' TwentyFour = new_addr1
 107
 108      apply_mask' TwentyThree =
 109        new_addr1 { octet3 = (apply_mask oct3 Seven bit) }
 110
 111      apply_mask' TwentyTwo =
 112        new_addr1 { octet3 = (apply_mask oct3 Six bit) }
 113
 114      apply_mask' TwentyOne =
 115        new_addr1 { octet3 = (apply_mask oct3 Five bit) }
 116
 117      apply_mask' Twenty =
 118        new_addr1 { octet3 = (apply_mask oct3 Four bit) }
 119
 120      apply_mask' Nineteen =
 121        new_addr1 { octet3 = (apply_mask oct3 Three bit) }
 122
 123      apply_mask' Eighteen =
 124        new_addr1 { octet3 = (apply_mask oct3 Two bit) }
 125
 126      apply_mask' Seventeen =
 127        new_addr1 { octet3 = (apply_mask oct3 One bit) }
 128
 129      apply_mask' Sixteen =
 130        new_addr2
 131
 132      apply_mask' Fifteen =
 133        new_addr2 { octet2 = (apply_mask oct2 Seven bit) }
 134
 135      apply_mask' Fourteen =
 136        new_addr2 { octet2 = (apply_mask oct2 Six bit) }
 137
 138      apply_mask' Thirteen =
 139        new_addr2 { octet2 = (apply_mask oct2 Five bit) }
 140
 141      apply_mask' Twelve =
 142        new_addr2 { octet2 = (apply_mask oct2 Four bit) }
 143
 144      apply_mask' Eleven =
 145        new_addr2 { octet2 = (apply_mask oct2 Three bit) }
 146
 147      apply_mask' Ten =
 148        new_addr2 { octet2 = (apply_mask oct2 Two bit) }
 149
 150      apply_mask' Nine =
 151        new_addr2 { octet2 = (apply_mask oct2 One bit) }
 152
 153      apply_mask' Eight =
 154        new_addr3 { octet2 = (apply_mask oct2 Zero bit) }
 155
 156      apply_mask' Seven =
 157        new_addr3 { octet1 = (apply_mask oct1 Seven bit) }
 158
 159      apply_mask' Six =
 160        new_addr3 { octet1 = (apply_mask oct1 Six bit) }
 161
 162      apply_mask' Five =
 163        new_addr3 { octet1 = (apply_mask oct1 Five bit) }
 164
 165      apply_mask' Four =
 166        new_addr3 { octet1 = (apply_mask oct1 Four bit) }
 167
 168      apply_mask' Three =
 169        new_addr3 { octet1 = (apply_mask oct1 Three bit) }
 170
 171      apply_mask' Two =
 172        new_addr3 { octet1 = (apply_mask oct1 Two bit) }
 173
 174      apply_mask' One =
 175        new_addr3 { octet1 = (apply_mask oct1 One bit) }
 176
 177      apply_mask' Zero =
 178        new_addr3 { octet1 = (apply_mask oct1 Zero bit) }
 179
 180
 181 instance Bounded IPv4Address where
 182   -- | The minimum possible IPv4 address, 0.0.0.0.
 183   minBound = IPv4Address minBound minBound minBound minBound
 184
 185   -- | The maximum possible IPv4 address, 255.255.255.255.
 186   maxBound = IPv4Address maxBound maxBound maxBound maxBound
 187
 188
 189
 190
 191 instance Enum IPv4Address where
 192   -- | Convert an 'Int' @x@ to an 'IPv4Address'. Each octet of @x@ is
 193   --   right-shifted by the appropriate number of bits, and the fractional
 194   --   part is dropped.
 195   toEnum y =
 196     IPv4Address oct1 oct2 oct3 oct4
 197     where
 198       -- Convert the input Int to a Word32 before we proceed. On x86,
 199       -- the Int that we get could be negative (half of all IP
 200       -- addresses correspond to negative numbers), and then the magic
 201       -- below doesn't work. The Word32 type is unsigned, so we do the
 202       -- math on that and then convert everything back to Int later on
 203       -- once we have four much-smaller non-negative numbers.
 204       x = fromIntegral y :: Word32
 205
 206       -- Chop off the higher octets. x1 = x `mod` 2^32, would be
 207       -- redundant.
 208       x2 = x `mod` 2^(24 :: Integer)
 209       x3 = x `mod` 2^(16 :: Integer)
 210       x4 = (fromIntegral $ x `mod` 2^(8  :: Integer)) :: Int
 211       -- Perform right-shifts. x4 doesn't need a shift.
 212       shifted_x1 = (fromIntegral $ x `quot` 2^(24 :: Integer)) :: Int
 213       shifted_x2 = (fromIntegral $ x2 `quot` 2^(16 :: Integer)) :: Int
 214       shifted_x3 = fromIntegral $ x3 `quot` 2^(8 :: Integer) :: Int
 215       oct1 = toEnum shifted_x1 :: Octet
 216       oct2 = toEnum shifted_x2 :: Octet
 217       oct3 = toEnum shifted_x3 :: Octet
 218       oct4 = toEnum x4 :: Octet
 219
 220   -- | Convert @addr@ to an 'Int' by converting each octet to an 'Int'
 221   --   and shifting the result to the left by 0,8.16, or 24 bits.
 222   fromEnum addr =
 223     (shifted_oct1) + (shifted_oct2) + (shifted_oct3) + oct4
 224     where
 225       oct1 = fromEnum (octet1 addr)
 226       oct2 = fromEnum (octet2 addr)
 227       oct3 = fromEnum (octet3 addr)
 228       oct4 = fromEnum (octet4 addr)
 229       shifted_oct1 = oct1 * 2^(24 :: Integer)
 230       shifted_oct2 = oct2 * 2^(16 :: Integer)
 231       shifted_oct3 = oct3 * 2^(8 :: Integer)
 232
 233 -- | Given two addresses, find the number of the most significant bit
 234 --   where they differ. If the addresses are the same, return
 235 --   Maskbits.Zero.
 236 most_sig_bit_different :: IPv4Address -> IPv4Address -> Maskbits
 237 most_sig_bit_different addr1 addr2
 238   | addr1 == addr2 = Maskbits.Zero
 239   | m1  /= n1  = Maskbits.One
 240   | m2  /= n2  = Two
 241   | m3  /= n3  = Three
 242   | m4  /= n4  = Four
 243   | m5  /= n5  = Five
 244   | m6  /= n6  = Six
 245   | m7  /= n7  = Seven
 246   | m8  /= n8  = Eight
 247   | m9  /= n9  = Nine
 248   | m10 /= n10 = Ten
 249   | m11 /= n11 = Eleven
 250   | m12 /= n12 = Twelve
 251   | m13 /= n13 = Thirteen
 252   | m14 /= n14 = Fourteen
 253   | m15 /= n15 = Fifteen
 254   | m16 /= n16 = Sixteen
 255   | m17 /= n17 = Seventeen
 256   | m18 /= n18 = Eighteen
 257   | m19 /= n19 = Nineteen
 258   | m20 /= n20 = Twenty
 259   | m21 /= n21 = TwentyOne
 260   | m22 /= n22 = TwentyTwo
 261   | m23 /= n23 = TwentyThree
 262   | m24 /= n24 = TwentyFour
 263   | m25 /= n25 = TwentyFive
 264   | m26 /= n26 = TwentySix
 265   | m27 /= n27 = TwentySeven
 266   | m28 /= n28 = TwentyEight
 267   | m29 /= n29 = TwentyNine
 268   | m30 /= n30 = Thirty
 269   | m31 /= n31 = ThirtyOne
 270   | m32 /= n32 = ThirtyTwo
 271   | otherwise  = Maskbits.Zero
 272   where
 273     m1  = (b1 oct1a)
 274     m2  = (b2 oct1a)
 275     m3  = (b3 oct1a)
 276     m4  = (b4 oct1a)
 277     m5  = (b5 oct1a)
 278     m6  = (b6 oct1a)
 279     m7  = (b7 oct1a)
 280     m8  = (b8 oct1a)
 281     m9  = (b1 oct2a)
 282     m10 = (b2 oct2a)
 283     m11 = (b3 oct2a)
 284     m12 = (b4 oct2a)
 285     m13 = (b5 oct2a)
 286     m14 = (b6 oct2a)
 287     m15 = (b7 oct2a)
 288     m16 = (b8 oct2a)
 289     m17 = (b1 oct3a)
 290     m18 = (b2 oct3a)
 291     m19 = (b3 oct3a)
 292     m20 = (b4 oct3a)
 293     m21 = (b5 oct3a)
 294     m22 = (b6 oct3a)
 295     m23 = (b7 oct3a)
 296     m24 = (b8 oct3a)
 297     m25 = (b1 oct4a)
 298     m26 = (b2 oct4a)
 299     m27 = (b3 oct4a)
 300     m28 = (b4 oct4a)
 301     m29 = (b5 oct4a)
 302     m30 = (b6 oct4a)
 303     m31 = (b7 oct4a)
 304     m32 = (b8 oct4a)
 305     oct1a = (octet1 addr1)
 306     oct2a = (octet2 addr1)
 307     oct3a = (octet3 addr1)
 308     oct4a = (octet4 addr1)
 309     n1  = (b1 oct1b)
 310     n2  = (b2 oct1b)
 311     n3  = (b3 oct1b)
 312     n4  = (b4 oct1b)
 313     n5  = (b5 oct1b)
 314     n6  = (b6 oct1b)
 315     n7  = (b7 oct1b)
 316     n8  = (b8 oct1b)
 317     n9  = (b1 oct2b)
 318     n10 = (b2 oct2b)
 319     n11 = (b3 oct2b)
 320     n12 = (b4 oct2b)
 321     n13 = (b5 oct2b)
 322     n14 = (b6 oct2b)
 323     n15 = (b7 oct2b)
 324     n16 = (b8 oct2b)
 325     n17 = (b1 oct3b)
 326     n18 = (b2 oct3b)
 327     n19 = (b3 oct3b)
 328     n20 = (b4 oct3b)
 329     n21 = (b5 oct3b)
 330     n22 = (b6 oct3b)
 331     n23 = (b7 oct3b)
 332     n24 = (b8 oct3b)
 333     n25 = (b1 oct4b)
 334     n26 = (b2 oct4b)
 335     n27 = (b3 oct4b)
 336     n28 = (b4 oct4b)
 337     n29 = (b5 oct4b)
 338     n30 = (b6 oct4b)
 339     n31 = (b7 oct4b)
 340     n32 = (b8 oct4b)
 341     oct1b = (octet1 addr2)
 342     oct2b = (octet2 addr2)
 343     oct3b = (octet3 addr2)
 344     oct4b = (octet4 addr2)
 345
 346
 347 -- Test lists.
 348 ipv4address_tests :: TestTree
 349 ipv4address_tests =
 350   testGroup "IPv4 Address Tests" [
 351     test_enum,
 352     test_maxBound,
 353     test_minBound,
 354     test_most_sig_bit_different1,
 355     test_most_sig_bit_different2,
 356     test_ord_instance1,
 357     test_ord_instance2,
 358     test_ord_instance3,
 359     test_ord_instance4,
 360     test_to_enum ]
 361
 362 ipv4address_properties :: TestTree
 363 ipv4address_properties =
 364   testGroup
 365     "IPv4 Address Properties "
 366     [ prop_from_enum_to_enum_inverses_x32,
 367       prop_from_enum_to_enum_inverses_x64 ]
 368
 369 -- QuickCheck properties
 370 --
 371 -- We have two different tests to show that toEnum and fromEnum are
 372 -- inverses of one another. This part of the code isn't really
 373 -- type-safe, because the stupid Enum class insists that we use a
 374 -- machine 'Int' for our representation. Since IPv4 addresses can
 375 -- correspond to very large 32-bit integers, there's a possibility
 376 -- that our math is wrong in 32- but not 64-bits, and vice-versa.
 377 --
 378 -- tl;dr we want to ensure that this test passes when the 'Int' type
 379 -- is both 32-bit and 64-bit.
 380
 381 -- Generate "Small" 64-bit numbers, because almost all 64-bit integers are
 382 -- too large to satisfy our predicate (i.e. also be 32-bit integers).
 383 prop_from_enum_to_enum_inverses_x64 :: TestTree
 384 prop_from_enum_to_enum_inverses_x64 =
 385   testProperty "fromEnum and toEnum are inverses (x64)" prop
 386   where
 387     prop :: (Small Int64) -> Property
 388     prop x =
 389       0 <= x && x <= 2^(32 :: Integer) - 1 ==>
 390         fromIntegral (fromEnum (toEnum (fromIntegral x) :: IPv4Address)) == x
 391
 392 -- According to the QuickCheck documentation, we need the "Large"
 393 -- modifier to ensure that the test cases are drawn from the entire
 394 -- range of Int32 values.
 395 prop_from_enum_to_enum_inverses_x32 :: TestTree
 396 prop_from_enum_to_enum_inverses_x32 =
 397   testProperty "fromEnum and toEnum are inverses (x32)" prop
 398   where
 399     prop :: (Large Int32) -> Bool
 400     prop x =
 401       fromIntegral (fromEnum (toEnum (fromIntegral x) :: IPv4Address)) == x
 402
 403 -- HUnit Tests
 404 mk_testaddr :: Int -> Int -> Int -> Int -> IPv4Address
 405 mk_testaddr a b c d =
 406   IPv4Address oct1 oct2 oct3 oct4
 407   where
 408     oct1 = toEnum a :: Octet
 409     oct2 = toEnum b :: Octet
 410     oct3 = toEnum c :: Octet
 411     oct4 = toEnum d :: Octet
 412
 413
 414 test_minBound :: TestTree
 415 test_minBound =
 416   testCase desc $ actual @?= expected
 417   where
 418     desc = "minBound should be 0.0.0.0"
 419     expected = mk_testaddr 0 0 0 0
 420     actual = minBound :: IPv4Address
 421
 422
 423 test_maxBound :: TestTree
 424 test_maxBound =
 425   testCase desc $ actual @?= expected
 426   where
 427     desc = "maxBound should be 255.255.255.255"
 428     expected = mk_testaddr 255 255 255 255
 429     actual = maxBound :: IPv4Address
 430
 431
 432 test_enum :: TestTree
 433 test_enum =
 434   testCase desc $ actual @?= expected
 435   where
 436     desc = "enumerating a /24 gives the correct addresses"
 437     expected = ["192.168.0." ++ (show x) | x <- [0..255::Int] ]
 438     lb = mk_testaddr 192 168 0 0
 439     ub = mk_testaddr 192 168 0 255
 440     actual = map show [lb..ub]
 441
 442
 443 test_most_sig_bit_different1 :: TestTree
 444 test_most_sig_bit_different1 =
 445   testCase desc $ actual @?= expected
 446   where
 447     desc = "10.1.1.0 and 10.1.0.0 differ in bit 24"
 448     addr1 = mk_testaddr 10 1 1 0
 449     addr2 = (mk_testaddr 10 1 0 0)
 450     expected = TwentyFour
 451     actual = most_sig_bit_different addr1 addr2
 452
 453
 454
 455 test_most_sig_bit_different2 :: TestTree
 456 test_most_sig_bit_different2 =
 457   testCase desc $ actual @?= expected
 458   where
 459     desc = "10.1.2.0 and 10.1.1.0 differ in bit 23"
 460     addr1 = mk_testaddr 10 1 2 0
 461     addr2 = mk_testaddr 10 1 1 0
 462     expected = TwentyThree
 463     actual = most_sig_bit_different addr1 addr2
 464
 465
 466 test_to_enum :: TestTree
 467 test_to_enum =
 468   testCase desc $ actual @?= expected
 469   where
 470     desc     = "192.168.0.0 in base-10 is 3232235520"
 471     expected = mk_testaddr 192 168 0 0
 472     -- We declare the big number as Word32 because otherwise, on x86,
 473     -- we get a warning that it's too big to fit in a 32-bit integer.
 474     -- Ultimately we convert it to a (negative) Int on those systems
 475     -- anyway, but the gymnastics declare our intent to the compiler.
 476     actual   = toEnum (fromIntegral (3232235520 :: Word32)) :: IPv4Address
 477
 478
 479 test_ord_instance1 :: TestTree
 480 test_ord_instance1 =
 481   testCase desc $ actual @?= expected
 482   where
 483     desc     = "127.0.0.0 is less than 127.0.0.1"
 484     addr1 = mk_testaddr 127 0 0 0
 485     addr2 = mk_testaddr 127 0 0 1
 486     expected = True
 487     actual   = addr1 <= addr2
 488
 489
 490 test_ord_instance2 :: TestTree
 491 test_ord_instance2 =
 492   testCase desc $ actual @?= expected
 493   where
 494     desc     = "127.0.0.0 is less than 127.0.1.0"
 495     addr1 = mk_testaddr 127 0 0 0
 496     addr2 = mk_testaddr 127 0 1 0
 497     expected = True
 498     actual   = addr1 <= addr2
 499
 500 test_ord_instance3 :: TestTree
 501 test_ord_instance3 =
 502   testCase desc $ actual @?= expected
 503   where
 504     desc     = "127.0.0.0 is less than 127.1.0.0"
 505     addr1 = mk_testaddr 127 0 0 0
 506     addr2 = mk_testaddr 127 1 0 0
 507     expected = True
 508     actual   = addr1 <= addr2
 509
 510 test_ord_instance4 :: TestTree
 511 test_ord_instance4 =
 512   testCase desc $ actual @?= expected
 513   where
 514     desc     = "127.0.0.0 is less than 128.0.0.0"
 515     addr1 = mk_testaddr 127 0 0 0
 516     addr2 = mk_testaddr 128 0 0 0
 517     expected = True
 518     actual   = addr1 <= addr2