diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -13,6 +13,7 @@ {-| A unified IP data for 'IPv4' and 'IPv6'. + To create this, use the data constructors. Or use 'read' @"192.0.2.1"@ :: 'IP', for example. Also, @"192.0.2.1"@ can be used as literal with OverloadedStrings. -} data IP = IPv4 { ipv4 :: IPv4 } @@ -31,13 +32,13 @@ {-| The abstract data structure to express an IPv4 address. - To create this, use 'toIPv4'. Or use 'read' @\"192.0.2.1\"@ :: 'IPv4', for example. Or use @\"192.0.2.1\"@ with OverloadedStrings. + To create this, use 'toIPv4'. Or use 'read' @\"192.0.2.1\"@ :: 'IPv4', for example. Also, @\"192.0.2.1\"@ can be used as literal with OverloadedStrings. -} newtype IPv4 = IP4 IPv4Addr deriving (Eq, Ord) {-| The abstract data structure to express an IPv6 address. - To create this, use 'toIPv6'. Or use 'read' @\"2001:DB8::1\"@ :: 'IPv6', for example. Or use @\"2001:DB8::1\"@ with OverloadedStrings. + To create this, use 'toIPv6'. Or use 'read' @\"2001:DB8::1\"@ :: 'IPv6', for example. Also, @\"2001:DB8::1\"@ can be used as literal with OverloadedStrings. -} newtype IPv6 = IP6 IPv6Addr deriving (Eq, Ord) @@ -103,17 +104,22 @@ -- Read -- +instance Read IP where + readsPrec _ = parseIP + instance Read IPv4 where readsPrec _ = parseIPv4 instance Read IPv6 where readsPrec _ = parseIPv6 -instance IsString IPv4 where - fromString = read - -instance IsString IPv6 where - fromString = read +parseIP :: String -> [(IP,String)] +parseIP cs = + case runParser ip4 cs of + (Just ip,rest) -> [(IPv4 ip,rest)] + (Nothing,_) -> case runParser ip6 cs of + (Just ip,rest) -> [(IPv6 ip,rest)] + (Nothing,_) -> error $ "parseIP" ++ cs parseIPv4 :: String -> [(IPv4,String)] parseIPv4 cs = case runParser ip4 cs of @@ -124,6 +130,20 @@ parseIPv6 cs = case runParser ip6 cs of (Nothing,_) -> error $ "parseIPv6 " ++ cs (Just a6,rest) -> [(a6,rest)] + +---------------------------------------------------------------- +-- +-- IsString +-- + +instance IsString IP where + fromString = read + +instance IsString IPv4 where + fromString = read + +instance IsString IPv6 where + fromString = read ---------------------------------------------------------------- -- diff --git a/Data/IP/Range.hs b/Data/IP/Range.hs --- a/Data/IP/Range.hs +++ b/Data/IP/Range.hs @@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} module Data.IP.Range where -import Data.Bits import Control.Monad +import Data.Bits import Data.IP.Addr import Data.IP.Mask +import Data.String import Text.Appar.String ---------------------------------------------------------------- @@ -12,6 +13,7 @@ {-| A unified data for 'AddrRange' 'IPv4' and 'AddrRange' 'IPv6'. To create this, use 'read' \"192.0.2.0/24\" :: 'IPRange'. + Also, \"192.0.2.0/24\" can be used as literal with OverloadedStrings. -} data IPRange = IPv4Range { ipv4range :: AddrRange IPv4 } @@ -30,6 +32,7 @@ calculation. To create this, use 'makeAddrRange' or 'read' \"192.0.2.0/24\" :: 'AddrRange' 'IPv4'. + Also, \"192.0.2.0/24\" can be used as literal with OverloadedStrings. -} data AddrRange a = AddrRange { -- |The 'addr' function returns an address from 'AddrRange'. @@ -58,10 +61,10 @@ -- instance Read IPRange where - readsPrec _ = parseIPRange - + readsPrec _ = parseIPRange + parseIPRange :: String -> [(IPRange,String)] -parseIPRange cs = +parseIPRange cs = case runParser ip4range cs of (Just ip,rest) -> [(IPv4Range ip,rest)] (Nothing,_) -> case runParser ip6range cs of @@ -111,3 +114,17 @@ maskedIPv6 :: IPv6 -> IPv6 -> IPv6 IP6 (a1,a2,a3,a4) `maskedIPv6` IP6 (m1,m2,m3,m4) = IP6 (a1.&.m1,a2.&.m2,a3.&.m3,a4.&.m4) + +---------------------------------------------------------------- +-- +-- IsString +-- + +instance IsString IPRange where + fromString = read + +instance IsString (AddrRange IPv4) where + fromString = read + +instance IsString (AddrRange IPv6) where + fromString = read diff --git a/Data/IP/RouteTable.hs b/Data/IP/RouteTable.hs --- a/Data/IP/RouteTable.hs +++ b/Data/IP/RouteTable.hs @@ -16,8 +16,9 @@ , IPRTable -- ** Functions to manipulate an IP routing table , empty, insert, delete - , Data.IP.RouteTable.Internal.lookup + , I.lookup + , findMatch , fromList, toList ) where -import Data.IP.RouteTable.Internal +import Data.IP.RouteTable.Internal as I diff --git a/Data/IP/RouteTable/Internal.hs b/Data/IP/RouteTable/Internal.hs --- a/Data/IP/RouteTable/Internal.hs +++ b/Data/IP/RouteTable/Internal.hs @@ -7,6 +7,7 @@ -} module Data.IP.RouteTable.Internal where +import Control.Monad hiding (join) import Data.Bits import Data.IP.Addr import Data.IP.Op @@ -152,7 +153,7 @@ else node k2 tb2 v2 l (delete k1 r) | otherwise = s -node :: (Routable k) => AddrRange k -> k -> (Maybe a) -> IPRTable k a -> IPRTable k a -> IPRTable k a +node :: (Routable k) => AddrRange k -> k -> Maybe a -> IPRTable k a -> IPRTable k a -> IPRTable k a node _ _ Nothing Nil r = r node _ _ Nothing l Nil = l node k tb v l r = Node k tb v l r @@ -160,8 +161,9 @@ ---------------------------------------------------------------- {-| - The 'lookup' function looks up 'IPRTable' with a key of 'AddrRange' - and returns its value if exists. + The 'lookup' function looks up 'IPRTable' with a key of 'AddrRange'. + If a routing information in 'IPRTable' matches the key, its value + is returned. -} lookup :: Routable k => AddrRange k -> IPRTable k a -> Maybe a lookup k s = search k s Nothing @@ -180,6 +182,25 @@ then search k1 l vl else search k1 r vl | otherwise = res + +---------------------------------------------------------------- + +{-| + The 'findMatch' function looks up 'IPRTable' with a key of 'AddrRange'. + If the key matches routing informations in 'IPRTable', they are + returned. +-} + +findMatch :: MonadPlus m => Routable k => AddrRange k -> IPRTable k a -> m (AddrRange k, a) +findMatch _ Nil = mzero +findMatch k1 (Node k2 _ Nothing l r) + | k1 >:> k2 = findMatch k1 l `mplus` findMatch k1 r + | k2 >:> k1 = findMatch k1 l `mplus` findMatch k1 r + | otherwise = mzero +findMatch k1 (Node k2 _ (Just vl) l r) + | k1 >:> k2 = return (k2, vl) `mplus` findMatch k1 l `mplus` findMatch k1 r + | k2 >:> k1 = findMatch k1 l `mplus` findMatch k1 r + | otherwise = mzero ---------------------------------------------------------------- diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -1,5 +1,5 @@ Name: iproute -Version: 1.2.1 +Version: 1.2.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Tests where @@ -45,15 +45,20 @@ testCase "fromto IPv4" test_fromto_ipv4 , testCase "lookup IPv4" test_lookup_ipv4 , testCase "lookup2 IPv4" test_lookup_ipv4_2 + , testCase "findMatch IPv4" test_findMatch_ipv4 ] , testGroup "Test case for IP" [ testCase "toIPv4" test_toIPv4 , testCase "toIPv6" test_toIPv6 + , testCase "read IP" test_read_IP + , testCase "read IP 2" test_read_IP_2 , testCase "read IPv4" test_read_IPv4 , testCase "read IPv6" test_read_IPv6 , testCase "read IPv6 2" test_read_IPv6_2 - , testCase "read IPv4 range" test_read_IPv4_range + , testCase "read IP range" test_read_IP_range + , testCase "read IP range 2" test_read_IP_range_2 , testCase "read IPv6 range" test_read_IPv6_range + , testCase "read IPv6 range" test_read_IPv6_range , testCase "makeAddrRange IPv4" test_makeAddrRange_IPv4 , testCase "makeAddrRange IPv6" test_makeAddrRange_IPv6 , testCase "contains IPv4" test_contains_IPv4 @@ -237,6 +242,12 @@ test_toIPv6 :: Assertion test_toIPv6 = show (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) @?= "2001:db8:00:00:00:00:00:01" +test_read_IP :: Assertion +test_read_IP = (read "192.0.2.1" :: IP) @?= IPv4 (read "192.0.2.1" :: IPv4) + +test_read_IP_2 :: Assertion +test_read_IP_2 = (read "2001:db8:00:00:00:00:00:01" :: IP) @?= IPv6 (read "2001:db8:00:00:00:00:00:01" :: IPv6) + test_read_IPv4 :: Assertion test_read_IPv4 = show (read "192.0.2.1" :: IPv4) @?= "192.0.2.1" @@ -246,6 +257,14 @@ test_read_IPv6_2 :: Assertion test_read_IPv6_2 = show (read "2001:240:11e:c00::101" :: IPv6) @?= "2001:240:11e:c00:00:00:00:101" +test_read_IP_range :: Assertion +test_read_IP_range = (read "192.0.2.1/24" :: IPRange) + @?= IPv4Range (read "192.0.2.0/24" :: AddrRange IPv4) + +test_read_IP_range_2 :: Assertion +test_read_IP_range_2 = (read "2001:db8:00:00:00:00:00:01/48" :: IPRange) + @?= IPv6Range (read "2001:db8:00:00:00:00:00:01/48" :: AddrRange IPv6) + test_read_IPv4_range :: Assertion test_read_IPv4_range = show (read "192.0.2.1/24" :: AddrRange IPv4) @?= "192.0.2.0/24" @@ -292,11 +311,11 @@ ipv4_list :: [AddrRange IPv4] ipv4_list = [ - read "0.0.0.0/0" - , read "133.4.0.0/16" - , read "133.5.0.0/16" - , read "133.5.16.0/24" - , read "133.5.23.0/24" + "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" ] test_fromto_ipv4 :: Assertion @@ -307,24 +326,53 @@ test_lookup_ipv4 :: Assertion test_lookup_ipv4 = do let rt = fromList pairs - lookup (read "127.0.0.1") rt @?= Just (read "0.0.0.0/0") - lookup (read "133.3.0.1") rt @?= Just (read "0.0.0.0/0") - lookup (read "133.4.0.0") rt @?= Just (read "133.4.0.0/16") - lookup (read "133.4.0.1") rt @?= Just (read "133.4.0.0/16") - lookup (read "133.5.16.0") rt @?= Just (read "133.5.16.0/24") - lookup (read "133.5.16.1") rt @?= Just (read "133.5.16.0/24") + 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 test_lookup_ipv4_2 :: Assertion test_lookup_ipv4_2 = do let rt = fromList pairs - lookup (read "127.0.0.1") rt @?= Nothing - lookup (read "133.3.0.1") rt @?= Nothing - lookup (read "133.4.0.0") rt @?= Just (read "133.4.0.0/16") - lookup (read "133.4.0.1") rt @?= Just (read "133.4.0.0/16") - lookup (read "133.5.16.0") rt @?= Just (read "133.5.16.0/24") - lookup (read "133.5.16.1") rt @?= Just (read "133.5.16.0/24") + lookup "127.0.0.1" rt @?= Nothing + lookup "133.3.0.1" rt @?= Nothing + 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 ipv4_list' = tail ipv4_list pairs = zip ipv4_list' ipv4_list' + +test_findMatch_ipv4 :: Assertion +test_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 + +----------------------------------------------------------------