diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -169,16 +169,16 @@ (Just ip,rest) -> [(IPv4 ip,rest)] (Nothing,_) -> case runParser ip6 cs of (Just ip,rest) -> [(IPv6 ip,rest)] - (Nothing,_) -> error $ "parseIP" ++ cs + (Nothing,_) -> [] parseIPv4 :: String -> [(IPv4,String)] parseIPv4 cs = case runParser ip4 cs of - (Nothing,_) -> error $ "parseIPv4 " ++ cs + (Nothing,_) -> [] (Just a4,rest) -> [(a4,rest)] parseIPv6 :: String -> [(IPv6,String)] parseIPv6 cs = case runParser ip6 cs of - (Nothing,_) -> error $ "parseIPv6 " ++ cs + (Nothing,_) -> [] (Just a6,rest) -> [(a6,rest)] ---------------------------------------------------------------- @@ -236,8 +236,8 @@ where check ns = when (length ns > 4) (fail "IPv6 address -- more than 4 hex") -colon2 :: Parser String -colon2 = string "::" +colon2 :: Parser () +colon2 = void $ string "::" format :: [Int] -> [Int] -> Parser [Int] format bs1 bs2 = do diff --git a/Data/IP/Range.hs b/Data/IP/Range.hs --- a/Data/IP/Range.hs +++ b/Data/IP/Range.hs @@ -99,7 +99,7 @@ ip4range :: Parser (AddrRange IPv4) ip4range = do ip <- ip4 - len <- option 32 $ do { char '/'; dig } + len <- option 32 $ char '/' >> dig check len let msk = maskIPv4 len adr = ip `maskedIPv4` msk @@ -113,7 +113,7 @@ ip6range :: Parser (AddrRange IPv6) ip6range = do ip <- ip6 - len <- option 128 $ do { char '/'; dig } + len <- option 128 $ char '/' >> dig check len let msk = maskIPv6 len adr = ip `maskedIPv6` msk diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -1,5 +1,5 @@ Name: iproute -Version: 1.2.7 +Version: 1.2.8 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -12,14 +12,12 @@ way branching removed. Both IPv4 and IPv6 are supported. Category: Algorithms, Network -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.10 Build-Type: Simple -Extra-Source-Files: test/Test.hs test/IPv4Search.hs test/Makefile -library - if impl(ghc >= 6.12) - GHC-Options: -Wall -fno-warn-unused-do-bind - else - GHC-Options: -Wall + +Library + Default-Language: Haskell2010 + GHC-Options: -Wall Exposed-Modules: Data.IP Data.IP.RouteTable Other-Modules: Data.IP.Addr @@ -32,6 +30,31 @@ , byteorder , containers , network + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + HS-Source-Dirs: test + Ghc-Options: -threaded -Wall + Main-Is: doctests.hs + Build-Depends: base + , doctest >= 0.9.3 + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: ., test + Ghc-Options: -Wall + Main-Is: Spec.hs + Other-Modules: RouteTableSpec + Build-Depends: base + , hspec + , QuickCheck + , appar + , byteorder + , containers + , network + Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/iproute.git diff --git a/test/IPv4Search.hs b/test/IPv4Search.hs deleted file mode 100644 --- a/test/IPv4Search.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Main where - -import Control.Exception -import Data.IP -import Data.IP.RouteTable -import Prelude hiding (lookup, catch) -import System.Environment - -main :: IO () -main = flip catch handler $ do - as <- getArgs - let file = as !! 0 - ip = as !! 1 - range = ip ++ "/32" - target = readIPv4Range range - rt <- loadRoutes file - let res = lookup target rt - print res - where - handler :: ErrorCall -> IO () - handler _ = help - -loadRoutes :: FilePath -> IO (IPRTable IPv4 (AddrRange IPv4)) -loadRoutes file = do - cs <- readFile file - let ls = lines cs - rs = map readIPv4Range ls - kvs = zip rs rs -- value is AddrRange itself in this test - radish = fromList kvs - return radish - -readIPv4Range :: String -> AddrRange IPv4 -readIPv4Range = read - -help :: IO () -help = do - putStrLn "Usage:" - putStrLn " ipv4_search file IPv4" - diff --git a/test/Makefile b/test/Makefile deleted file mode 100644 --- a/test/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -PROG = ipv4_search - -all: - ghc -Wall -fno-warn-unused-do-bind -i.. --make -o $(PROG) IPv4Search.hs - -clean: - rm -f *.hi *.o $(PROG) diff --git a/test/RouteTableSpec.hs b/test/RouteTableSpec.hs new file mode 100644 --- /dev/null +++ b/test/RouteTableSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module RouteTableSpec where + +import Control.Monad +import Data.IP +import Data.IP.RouteTable.Internal +import Data.List (sort, nub) +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 = do + a <- replicateM adrlen (choose (0, width)) + return $ func a + +arbitraryIP :: Routable a => Gen a -> Int -> Gen (AddrRange a) +arbitraryIP adrGen msklen = do + adr <- adrGen + len <- choose (0,msklen) + return $ makeAddrRange adr len + +---------------------------------------------------------------- +-- +-- 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) + +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) == nub (sort 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main where - ----------------------------------------------------------------- --- --- Tests for IP.RouteTable --- --- runghc -i.. Test.hs --- - -import Control.Monad -import Data.IP -import Data.IP.RouteTable.Internal -import Data.List (sort, nub) -import Prelude hiding (lookup) -import Test.Framework.Providers.DocTest -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.Framework.TH.Prime -import Test.HUnit -import Test.QuickCheck - ----------------------------------------------------------------- - -main :: IO () -main = $(defaultMainGenerator) - ----------------------------------------------------------------- - -doc_test :: DocTests -doc_test = docTest ["../Data/IP.hs", "../Data/IP/RouteTable.hs"] ["-i..", "-XOverloadedStrings"] - ----------------------------------------------------------------- --- --- 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 = do - a <- replicateM adrlen (choose (0, width)) - return $ func a - -arbitraryIP :: Routable a => Gen a -> Int -> Gen (AddrRange a) -arbitraryIP adrGen msklen = do - adr <- adrGen - len <- choose (0,msklen) - return $ makeAddrRange adr len - ----------------------------------------------------------------- --- --- Properties --- - -prop_sort_ipv4 :: [AddrRange IPv4] -> Bool -prop_sort_ipv4 = sort_ip - -prop_sort_ipv6 :: [AddrRange IPv6] -> Bool -prop_sort_ipv6 = sort_ip - -sort_ip :: (Routable a, Ord a) => [AddrRange a] -> Bool -sort_ip xs = fromList (zip xs xs) == fromList (zip xs' xs') - where - xs' = sort xs - ----------------------------------------------------------------- - -prop_fromto_ipv4 :: [AddrRange IPv4] -> Bool -prop_fromto_ipv4 = fromto_ip - -prop_fromto_ipv6 :: [AddrRange IPv6] -> Bool -prop_fromto_ipv6 = fromto_ip - -fromto_ip :: (Routable a, Ord a) => [AddrRange a] -> Bool -fromto_ip xs = nub (sort xs) == nub (sort ys) - where - ys = map fst . toList . fromList $ zip xs xs - ----------------------------------------------------------------- - -prop_ord_ipv4 :: [AddrRange IPv4] -> Bool -prop_ord_ipv4 = ord_ip - -prop_ord_ipv6 :: [AddrRange IPv6] -> Bool -prop_ord_ipv6 = ord_ip - -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 - ----------------------------------------------------------------- - -prop_insert_lookup_ipv4 :: AddrRange IPv4 -> [AddrRange IPv4] -> Bool -prop_insert_lookup_ipv4 = insert_lookup_ip - -prop_insert_lookup_ipv6 :: AddrRange IPv6 -> [AddrRange IPv6] -> Bool -prop_insert_lookup_ipv6 = insert_lookup_ip - -insert_lookup_ip :: Routable a => AddrRange a -> [AddrRange a] -> Bool -insert_lookup_ip k xs = lookup k (insert k k t) == Just k - where - rs = zip xs xs - t = fromList rs - -prop_search_ipv4 :: AddrRange IPv4 -> [AddrRange IPv4] -> Bool -prop_search_ipv4 = search_ip - -prop_search_ipv6 :: AddrRange IPv6 -> [AddrRange IPv6] -> Bool -prop_search_ipv6 = search_ip - -search_ip :: Routable a => AddrRange a -> [AddrRange a] -> Bool -search_ip k xs = lookup k (fromList (zip xs xs)) == linear k xs - -linear :: Routable a => AddrRange a -> [AddrRange a] -> Maybe (AddrRange a) -linear = linear' Nothing - where - linear' a _ [] = a - linear' Nothing k (x:xs) - | x >:> k = linear' (Just x) k xs - | otherwise = linear' Nothing k xs - linear' (Just a) k (x:xs) - | x >:> k = if mlen x > mlen a - then linear' (Just x) k xs - else linear' (Just a) k xs - | otherwise = linear' (Just a) k xs - ----------------------------------------------------------------- - -prop_delete_ipv4 :: [AddrRange IPv6] -> Property -prop_delete_ipv4 = delete_ip - -prop_delete_ipv6 :: [AddrRange IPv6] -> Property -prop_delete_ipv6 = delete_ip - -delete_ip :: Routable a => [AddrRange a] -> Property -delete_ip xs = xs /= [] ==> isOrdered (delete i t) - where - rs = zip xs xs - t = fromList rs - i = head xs - -prop_insert_delete_ipv4 :: AddrRange IPv4 -> [AddrRange IPv4] -> Property -prop_insert_delete_ipv4 = insert_delete_ip - -prop_insert_delete_ipv6 :: AddrRange IPv6 -> [AddrRange IPv6] -> Property -prop_insert_delete_ipv6 = insert_delete_ip - -insert_delete_ip :: Routable a => AddrRange a -> [AddrRange a] -> Property -insert_delete_ip k xs = lookup k t == Nothing ==> delete k (insert k k t) == t - where - rs = zip xs xs - t = fromList rs - -prop_delete_insert_ipv4 :: [AddrRange IPv4] -> Property -prop_delete_insert_ipv4 = delete_insert_ip - -prop_delete_insert_ipv6 :: [AddrRange IPv6] -> Property -prop_delete_insert_ipv6 = delete_insert_ip - -delete_insert_ip :: Routable a => [AddrRange a] -> Property -delete_insert_ip xs = xs /= [] ==> insert k k (delete k t) == t - where - rs = zip xs xs - t = fromList rs - k = head xs - -prop_delete_lookup_ipv4 :: [AddrRange IPv4] -> Property -prop_delete_lookup_ipv4 = delete_lookup_ip - -prop_delete_lookup_ipv6 :: [AddrRange IPv6] -> Property -prop_delete_lookup_ipv6 = delete_lookup_ip - -delete_lookup_ip :: Routable a => [AddrRange a] -> Property -delete_lookup_ip xs = xs /= [] ==> case lookup k (delete k t) of - Nothing -> True - Just r -> r /= k && r >:> k - where - rs = zip xs xs - t = fromList rs - k = head xs - -prop_convert_ipv4 :: IPv4 -> Property -prop_convert_ipv4 ip = True ==> (toIPv4 . fromIPv4) ip == ip - -prop_convert_ipv6 :: IPv6 -> Property -prop_convert_ipv6 ip = True ==> (toIPv6 . fromIPv6) ip == ip - ----------------------------------------------------------------- - -ipv4_list :: [AddrRange IPv4] -ipv4_list = [ - "0.0.0.0/0" - , "133.4.0.0/16" - , "133.5.0.0/16" - , "133.5.16.0/24" - , "133.5.23.0/24" - ] - -case_fromto_ipv4 :: Assertion -case_fromto_ipv4 = (sort . toList . fromList $ pairs) @?= pairs - where - pairs = sort $ zip ipv4_list ipv4_list - -case_lookup_ipv4 :: Assertion -case_lookup_ipv4 = do - let rt = fromList pairs - lookup "127.0.0.1" rt @?= Just "0.0.0.0/0" - lookup "133.3.0.1" rt @?= Just "0.0.0.0/0" - lookup "133.4.0.0" rt @?= Just "133.4.0.0/16" - lookup "133.4.0.1" rt @?= Just "133.4.0.0/16" - lookup "133.5.16.0" rt @?= Just "133.5.16.0/24" - lookup "133.5.16.1" rt @?= Just "133.5.16.0/24" - where - pairs = zip ipv4_list ipv4_list - -case_findMatch_ipv4 :: Assertion -case_findMatch_ipv4 = do - let rt = fromList pairs - findMatch "127.0.0.1" rt @?= [] - findMatch "133.5.23.0/23" rt @?= [("133.5.23.0/24","133.5.23.0/24")] - findMatch "133.5.0.0/16" rt @?= [ - ("133.5.0.0/16","133.5.0.0/16") - , ("133.5.16.0/24","133.5.16.0/24") - , ("133.5.23.0/24","133.5.23.0/24") - ] - findMatch "133.4.0.0/16" rt @?= [("133.4.0.0/16", "133.4.0.0/16")] - findMatch "133.4.0.0/15" rt @?= [ - ("133.4.0.0/16","133.4.0.0/16") - , ("133.5.0.0/16","133.5.0.0/16") - , ("133.5.16.0/24","133.5.16.0/24") - , ("133.5.23.0/24","133.5.23.0/24") - ] - findMatch "0.0.0.0/0" rt @?= [ - ("0.0.0.0/0", "0.0.0.0/0") - , ("133.4.0.0/16", "133.4.0.0/16") - , ("133.5.0.0/16", "133.5.0.0/16") - , ("133.5.16.0/24", "133.5.16.0/24") - , ("133.5.23.0/24", "133.5.23.0/24") - ] - where - pairs = zip ipv4_list ipv4_list - ----------------------------------------------------------------- diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["-XOverloadedStrings", "Data/IP.hs", "Data/IP/RouteTable.hs"]