src/IPv4Address.hs

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