iproute-1.8.0: test/RouteTableSpec.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module RouteTableSpec where

import Control.Monad
import qualified Data.Foldable as Foldable
import Data.Function (on)
import Data.IP
import Data.IP.RouteTable.Internal
import Data.List (nub, sort)
import qualified Data.List as List
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck

----------------------------------------------------------------
--
-- Arbitrary
--

instance Arbitrary (AddrRange IPv4) where
    arbitrary = arbitraryIP arbitrary 32

instance Arbitrary (AddrRange IPv6) where
    arbitrary = arbitraryIP arbitrary 128

instance Arbitrary IPv4 where
    arbitrary = arbitraryAdr toIPv4 255 4

instance Arbitrary IPv6 where
    arbitrary = arbitraryAdr toIPv6 65535 8

arbitraryAdr :: Routable a => ([Int] -> a) -> Int -> Int -> Gen a
arbitraryAdr func width adrlen = func <$> replicateM adrlen (choose (0, width))

arbitraryIP :: Routable a => Gen a -> Int -> Gen (AddrRange a)
arbitraryIP adrGen msklen = makeAddrRange <$> adrGen <*> choose (0, msklen)

----------------------------------------------------------------
--
-- Spec
--

spec :: Spec
spec = do
    describe "fromList" $ do
        prop
            "creates the same tree for random input and ordered input"
            (sort_ip :: [AddrRange IPv4] -> Bool)
        prop
            "creates the same tree for random input and ordered input"
            (sort_ip :: [AddrRange IPv6] -> Bool)
        prop
            "stores input in the incremental order"
            (ord_ip :: [AddrRange IPv4] -> Bool)
        prop
            "stores input in the incremental order"
            (ord_ip :: [AddrRange IPv6] -> Bool)
    describe "toList" $ do
        prop
            "expands as sorted"
            (fromto_ip :: [AddrRange IPv4] -> Bool)
        prop
            "expands as sorted"
            (fromto_ip :: [AddrRange IPv6] -> Bool)
    describe "folds" $ do
        prop "foldl" prop_foldl
        prop "foldr" prop_foldr
    describe "monoid" $ do
        prop "monoid instance" prop_monoid

sort_ip :: (Routable a, Ord a) => [AddrRange a] -> Bool
sort_ip xs = fromList (zip xs xs) == fromList (zip xs' xs')
  where
    xs' = sort xs

fromto_ip :: (Routable a, Ord a) => [AddrRange a] -> Bool
fromto_ip xs = nub (sort xs) == ys
  where
    ys = map fst . toList . fromList $ zip xs xs

ord_ip :: Routable a => [AddrRange a] -> Bool
ord_ip xs = isOrdered . fromList $ zip xs xs

isOrdered :: Routable k => IPRTable k a -> Bool
isOrdered = foldt (\x v -> v && ordered x) True

ordered :: Routable k => IPRTable k a -> Bool
ordered Nil = True
ordered (Node k _ _ l r) = ordered' k l && ordered' k r
  where
    ordered' _ Nil = True
    ordered' k1 (Node k2 _ _ _ _) = k1 >:> k2

-- Foldl and foldr properties are adapted from Data.Map tests
prop_foldl :: Int -> [(AddrRange IPv4, Int)] -> Property
prop_foldl n ys =
    not (null ys) ==>
        let xs = List.nubBy ((==) `on` fst) ys
            m = fromList xs
         in Foldable.foldl (+) n m == List.foldr ((+) . snd) n xs
                && Foldable.foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs))
                && foldlWithKey (\b _ a -> a + b) n m == List.foldr ((+) . snd) n xs
                && foldlWithKey (\b k a -> (k, a) : b) [] m == reverse (List.sort xs)

prop_foldr :: Int -> [(AddrRange IPv4, Int)] -> Property
prop_foldr n ys =
    not (null ys) ==>
        let xs = List.nubBy ((==) `on` fst) ys
            m = fromList xs
         in Foldable.foldr (+) n m == List.foldr ((+) . snd) n xs
                && Foldable.foldr (:) [] m == List.map snd (List.sortBy (compare `on` fst) xs)
                && foldrWithKey (\_ a b -> a + b) n m == List.foldr ((+) . snd) n xs
                && foldrWithKey (\k a b -> (k, a) : b) [] m == List.sort xs

prop_monoid :: [(AddrRange IPv4, ())] -> [(AddrRange IPv4, ())] -> Property
prop_monoid xs ys =
    not (null xs) && not (null ys) ==>
        let xm = fromList xs
            ym = fromList ys
         in empty <> xm == xm
                && ym <> empty == ym
                && xm <> ym == fromList (xs ++ ys)