]> gitweb.michael.orlitzky.com - hath.git/blob - src/IPv4Address.hs
hath.cabal: add other-modules for the tasty test suite.
[hath.git] / 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 signed_x =
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 signed_x :: 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