diff --git a/Data/IP.hs b/Data/IP.hs new file mode 100644 --- /dev/null +++ b/Data/IP.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE FlexibleInstances #-} +{-| + Data structures to express IPv4, IPv6 and IP range. +-} +module Data.IP (IP(..), IPv4, IPv6, toIPv4, toIPv6, IPRange, addr, mask, mlen, (>:>), makeIPRange) where + +import Control.Monad +import Data.Bits +import Data.Char +import Data.Char +import Data.IntMap hiding (map) +import Data.List (foldl') +import Data.Word +import Text.ParserCombinators.Parsec +import Text.Printf + +---------------------------------------------------------------- +-- +-- Data definitions +-- + +-- This is host byte order +type IPv4Addr = Word32 +type IPv6Addr = (Word32,Word32,Word32,Word32) + +{-| + The abstract data structure to express an IPv4 address. + To create this, use 'toIPv4'. Or use 'read' @\"192.0.2.1\"@ :: 'IPv4', for example. +-} +newtype IPv4 = IPv4 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. +-} +newtype IPv6 = IPv6 IPv6Addr deriving (Eq, Ord) + +{-| + The IP range consists of an 'IP' address, a contiguous 'IP' mask, + and mask length. The contiguous 'IP' mask and the mask length + are essentially same information but contained for pre + calculation. + + To create this, use 'makeIPRange' or 'read' \"192.0.2.0/24\" :: 'IPRange' 'IPv4', for example. +-} +data (IP a) => IPRange a = + IPRange { + -- |The 'addr' function returns an 'IP' address from 'IPRange'. + addr :: a + -- |The 'mask' function returns a contiguous 'IP' mask from 'IPRange'. + , mask :: a + -- |The 'mlen' function returns a mask length from 'IPRange'. + , mlen :: Int + } deriving (Eq, Ord) + +---------------------------------------------------------------- +-- +-- Exported functions +-- + +{-| + The >:> operator takes two 'IPRange'. It returns 'True' if + the first 'IPRange' contains the second 'IPRange'. Otherwise, + it returns 'False'. +-} +(>:>) :: IP a => IPRange a -> IPRange a -> Bool +a >:> b = mlen a <= mlen b && (addr b `masked` mask a) == addr a + +{-| + The 'makeIPRange' functions takes an 'IP' address and a mask + length. It creates a bit mask from the mask length and masks + the 'IP' address, then returns 'IPRange' made of them. +-} +makeIPRange :: IP a => a -> Int -> IPRange a +makeIPRange ad len = let msk = intToMask len + adr = ad `masked` msk + in IPRange adr msk len + +---------------------------------------------------------------- +-- +-- IP Class +-- + +{-| + A class to contain IPv4 and IPv6. +-} +class Eq a => IP a where + {-| + The 'masked' function takes an 'IP' address and a contiguous + 'IP' mask and returned a masked 'IP' address. + -} + masked :: a -> a -> a + {-| + The 'intToMask' function takes 'Int' and returns a contiguous + 'IP' mask. + -} + intToMask :: Int -> a + {-| + The 'intToTBit' function takes 'Int' and returns an 'IP' address + whose only n-th bit is set. + -} + intToTBit :: Int -> a + {-| + The 'isZero' function takes an 'IP' address and an test bit 'IP' + address and returns 'True' is the bit is unset, otherwise + returns 'False'. + -} + isZero :: a -> a -> Bool + +instance IP IPv4 where + IPv4 a `masked` IPv4 m = IPv4 (a .&. m) + intToMask = maskIPv4 + intToTBit = intToTBitIPv4 + isZero a b = a `masked` b == IPv4 0 + +instance IP IPv6 where + IPv6 (a1,a2,a3,a4) `masked` IPv6 (m1,m2,m3,m4) = + IPv6 (a1.&.m1,a2.&.m2,a3.&.m3,a4.&.m4) + intToMask = maskIPv6 + intToTBit = intToTBitIPv6 + isZero a b = a `masked` b == IPv6 (0,0,0,0) + +---------------------------------------------------------------- +-- +-- Show for IP +-- + +instance Show IPv4 where + show = showIPv4 + +instance Show IPv6 where + show = showIPv6 + +showIPv4 :: IPv4 -> String +showIPv4 (IPv4 a) = show4 a + where + remQuo x = (x `mod` 256, x `div` 256) + show4 q = let (a4,q4) = remQuo q + (a3,q3) = remQuo q4 + (a2,q2) = remQuo q3 + (a1, _) = remQuo q2 + in printf "%d.%d.%d.%d" a1 a2 a3 a4 + +showIPv6 :: IPv6 -> String +showIPv6 (IPv6 (a1,a2,a3,a4)) = show6 a1 ++ ":" ++ show6 a2 ++ ":" ++ show6 a3 ++ ":" ++ show6 a4 + where + remQuo x = (x `mod` 65536, x `div` 65536) + show6 q = let (r2,q2) = remQuo q + (r1, _) = remQuo q2 + in printf "%02x:%02x" r1 r2 + +---------------------------------------------------------------- +-- +-- Show for IPRange +-- + +instance (IP a, Show a) => Show (IPRange a) where + show x = show (addr x) ++ "/" ++ show (mlen x) + +---------------------------------------------------------------- +-- +-- Mask +-- + +maskIPv4 :: Int -> IPv4 +maskIPv4 len = IPv4 (masksIPv4 ! len) + +maskIPv6 :: Int -> IPv6 +maskIPv6 len = IPv6 (masksIPv6 ! len) + +masksWord32 :: [Word32] +masksWord32 = take 33 $ iterate (flip shift 1) 0xffffffff + +masksIPv4 :: IntMap IPv4Addr +masksIPv4 = fromList $ zip [32,31..0] masksWord32 + +masksIPv6 :: IntMap IPv6Addr +masksIPv6 = fromList $ zip [128,127..0] ms + where + ms = m0 ++ m1 ++ m2 ++ m3 ++ m4 + m0 = [(all1,all1,all1,all1)] + m1 = map (\vmsk -> (all1,all1,all1,vmsk)) masks + m2 = map (\vmsk -> (all1,all1,vmsk,all0)) masks + m3 = map (\vmsk -> (all1,vmsk,all0,all0)) masks + m4 = map (\vmsk -> (vmsk,all0,all0,all0)) masks + masks = tail masksWord32 + all1 = 0xffffffff + all0 = 0x00000000 + +---------------------------------------------------------------- +-- +-- Test Bit +-- + +intToTBitIPv4 :: Int -> IPv4 +intToTBitIPv4 len = IPv4 (intToTBitsIPv4 ! len) + +intToTBitIPv6 :: Int -> IPv6 +intToTBitIPv6 len = IPv6 (intToTBitsIPv6 ! len) + +intToTBitsWord32 :: [Word32] +intToTBitsWord32 = iterate (flip shift (-1)) 0x80000000 + +intToTBitsIPv4 :: IntMap IPv4Addr +intToTBitsIPv4 = fromList $ zip [0..32] intToTBitsWord32 + +intToTBitsIPv6 :: IntMap IPv6Addr +intToTBitsIPv6 = fromList $ zip [0..128] bs + where + bs = b1 ++ b2 ++ b3 ++ b4 ++ b5 + b1 = map (\vbit -> (vbit,all0,all0,all0)) intToTBits + b2 = map (\vbit -> (all0,vbit,all0,all0)) intToTBits + b3 = map (\vbit -> (all0,all0,vbit,all0)) intToTBits + b4 = map (\vbit -> (all0,all0,all0,vbit)) intToTBits + b5 = [(all0,all0,all0,all0)] + intToTBits = take 32 $ intToTBitsWord32 + all0 = 0x00000000 + +---------------------------------------------------------------- +-- +-- Read for IP +-- + +instance Read IPv4 where + readsPrec _ = parseIPv4 + +instance Read IPv6 where + readsPrec _ = parseIPv6 + +parseIPv4 :: String -> [(IPv4,String)] +parseIPv4 cs = case parse (adopt ipv4) "parseIPv4" cs of + Right a4 -> a4 + Left _ -> error "parseIPv4" + +parseIPv6 :: String -> [(IPv6,String)] +parseIPv6 cs = case parse (adopt ipv6) "parseIPv6" cs of + Right a6 -> a6 + Left _ -> error "parseIPv6" + +---------------------------------------------------------------- +-- +-- Read for IPRange +-- + +instance Read (IPRange IPv4) where + readsPrec _ = parseIPv4Range + +instance Read (IPRange IPv6) where + readsPrec _ = parseIPv6Range + +parseIPv4Range :: String -> [(IPRange IPv4,String)] +parseIPv4Range cs = case parse (adopt ipv4range) "parseIPv4" cs of + Right r4 -> r4 + Left _ -> error "parseIPv4" + +parseIPv6Range :: String -> [(IPRange IPv6,String)] +parseIPv6Range cs = case parse (adopt ipv6range) "parseIPv6" cs of + Right r6 -> r6 + Left _ -> error "parseIPv6" + +---------------------------------------------------------------- +-- +-- Adopter for Read +-- + +adopt :: Parser a -> Parser [(a,String)] +adopt p = do x <- p + rest <- getInput + return [(x, rest)] + +---------------------------------------------------------------- +-- +-- IPv4 Parser +-- + +dig :: Parser Int +dig = do { char '0'; return 0 } <|> + do n <- oneOf ['1'..'9'] + ns <- many digit + let ms = map digitToInt (n:ns) + ret = foldl' (\x y -> x * 10 + y) 0 ms + return ret + +ipv4 :: Parser IPv4 +ipv4 = do + as <- dig `sepBy1` (char '.') + check as + return $ toIPv4 as + where + test errmsg adr = when (adr < 0 || 255 < adr) (unexpected errmsg) + check as = do let errmsg = "IPv4 adddress" + when (length as /= 4) (unexpected errmsg) + mapM_ (test errmsg) as + +ipv4range :: Parser (IPRange IPv4) +ipv4range = do + ip <- ipv4 + len <- option 32 $ do { char '/'; dig } + check len + return $ IPRange ip (maskIPv4 len) len + where + check len = when (len < 0 || 32 < len) (unexpected "IPv4 mask length") + +---------------------------------------------------------------- +-- +-- IPv6 Parser (RFC 4291) +-- + +hex :: Parser Int +hex = do ns <- many1 hexDigit + check ns + let ms = map digitToInt ns + val = foldl' (\x y -> x * 16 + y) 0 ms + return val + where + check ns = when (length ns > 4) (unexpected "IPv6 address -- more than 4 hex") + +ipv6 :: Parser IPv6 +ipv6 = do + as <- ipv6' + return $ toIPv6 as + +ipv6range :: Parser (IPRange IPv6) +ipv6range = do + ip <- ipv6 + len <- option 128 $ do { char '/'; dig } + check len + return $ IPRange ip (maskIPv6 len) len + where + check len = when (len < 0 || 128 < len) (unexpected ("IPv6 mask length: " ++ show len)) + +ipv6' :: Parser [Int] +ipv6' = do colon2 + bs <- option [] hexcolon + rs <- format [] bs + return rs + <|> try (do rs <- hexcolon + check rs + return rs) + <|> do bs1 <- hexcolon2 + bs2 <- option [] hexcolon + rs <- format bs1 bs2 + return rs + where + colon2 = string "::" + hexcolon = do bs <- hex `sepBy1` (char ':') + return bs + hexcolon2 = do bs <- manyTill (do{ b <- hex; char ':'; return b }) (char ':') + return bs + format bs1 bs2 = do let len1 = length bs1 + len2 = length bs2 + when (len1 > 7) (unexpected "IPv6 address") + when (len2 > 7) (unexpected "IPv6 address") + let len = 8 - len1 - len2 + when (len <= 0) (unexpected "IPv6 address") + let spring = take len $ repeat 0 + return $ bs1 ++ spring ++ bs2 + check bs = when (length bs /= 8) (unexpected "IPv6 address") + +---------------------------------------------------------------- +-- +-- IntToIP +-- + +{-| + The 'toIPv4' function takes a list of 'Int' and returns 'IPv4'. + For example, 'toIPv4' @[192,0,2,1]@. +-} +toIPv4 :: [Int] -> IPv4 +toIPv4 = IPv4 . toWord32 + where + toWord32 [a1,a2,a3,a4] = fromIntegral $ shift a1 24 + shift a2 16 + shift a3 8 + a4 + toWord32 _ = error "toWord32" + +{-| + The 'toIPv6' function takes a list of 'Int' and returns 'IPv6'. + For example, 'toIPv6' @[0x2001,0xDB8,0,0,0,0,0,1]@. +-} +toIPv6 :: [Int] -> IPv6 +toIPv6 ad = let [x1,x2,x3,x4] = map toWord32 $ split2 ad + in IPv6 (x1,x2,x3,x4) + where + split2 [] = [] + split2 x = take 2 x : split2 (drop 2 x) + toWord32 [a1,a2] = fromIntegral $ shift a1 16 + a2 + toWord32 _ = error "toWord32" diff --git a/Data/IP/RouteTable.hs b/Data/IP/RouteTable.hs new file mode 100644 --- /dev/null +++ b/Data/IP/RouteTable.hs @@ -0,0 +1,11 @@ +{-| + IP routing table is a tree of 'IPRange' + to search one of them on the longest + match base. It is a kind of TRIE with one + way branching removed. Both IPv4 and IPv6 + are supported. +-} +module Data.IP.RouteTable (IPRTable, empty, insert, lookup, fromList, toList) where + +import Prelude hiding (lookup) +import Data.IP.RouteTable.Internal diff --git a/Data/IP/RouteTable/Internal.hs b/Data/IP/RouteTable/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/IP/RouteTable/Internal.hs @@ -0,0 +1,124 @@ +{-| + IP routing table is a tree of 'IPRange' + to search one of them on the longest + match base. It is a kind of TRIE with one + way branching removed. Both IPv4 and IPv6 + are supported. +-} +module Data.IP.RouteTable.Internal where + +import Data.IP +import Data.List (foldl') +import Prelude hiding (lookup) + +{-| + The Tree structure for IP routing table based on TRIE with + one way branching removed. This is an abstracted data structure, + so you cannot touch its inside. Please use 'insert' or 'lookup', instead. +-} +data IPRTable k a = Nil | Node (Entry k a) (IPRTable k a) (IPRTable k a) deriving (Eq, Show) + +data (IP k) => Entry k a = Entry (IPRange k) k (Maybe a) deriving (Eq, Show) + +---------------------------------------------------------------- + +{-| + The 'empty' function returns an empty IP routing table. +-} +empty :: IP k => IPRTable k a +empty = Nil + +---------------------------------------------------------------- + +newEntry :: (IP k) => IPRange k -> Maybe a -> Entry k a +newEntry k v = Entry k (intToTBit (mlen k)) v + +{-| + The 'insert' function inserts a value with a key of 'IPRange' to 'IPRTable' + and returns a new 'IPRTable'. +-} +insert :: (IP k) => IPRange k -> a -> IPRTable k a -> IPRTable k a +insert k v s = inject (newEntry k (Just v)) s + +inject :: (IP k) => Entry k a -> IPRTable k a -> IPRTable k a +inject e Nil = Node e Nil Nil +inject e1@(Entry k1 _ _) s@(Node e2@(Entry k2 _ _) l r) + | k1 == k2 = Node e1 l r + | k2 >:> k1 = if isLeft k1 e2 + then Node e2 (inject e1 l) r + else Node e2 l (inject e1 r) + | k1 >:> k2 = if isLeft k2 e1 + then Node e1 s Nil + else Node e1 Nil s + | otherwise = let n = Node e1 Nil Nil + in glue n s + +glue :: IP k => IPRTable k a -> IPRTable k a -> IPRTable k a +glue s1@(Node (Entry k1 _ _) _ _) s2@(Node (Entry k2 _ _) _ _) = + let kg = makeGlueRange 0 k1 k2 + eg = newEntry kg Nothing + in if isLeft k1 eg + then Node eg s1 s2 + else Node eg s2 s1 +glue _ _ = error "glue" + +makeGlueRange :: (IP k) => Int -> IPRange k -> IPRange k -> IPRange k +makeGlueRange n k1 k2 + | addr k1 `masked` mk == addr k2 `masked` mk = makeGlueRange (n + 1) k1 k2 + + | otherwise = makeIPRange (addr k1) (n - 1) + where + mk = intToMask n + +isLeft :: IP k => IPRange k -> Entry k a -> Bool +isLeft adr (Entry _ tb _) = isZero (addr adr) tb + +---------------------------------------------------------------- + +{-| + The 'lookup' function looks up 'IPRTable' with a key of 'IPRange' + and returns its value if exists. +-} +lookup :: IP k => IPRange k -> IPRTable k a -> Maybe a +lookup k s = search k s Nothing + +search :: IP k => IPRange k -> IPRTable k a -> Maybe a -> Maybe a +search _ Nil res = res +search k1 (Node e2@(Entry k2 _ Nothing) l r) res + | k1 == k2 = res + | k2 >:> k1 = if isLeft k1 e2 + then search k1 l res + else search k1 r res + | otherwise = res +search k1 (Node e2@(Entry k2 _ vl) l r) res + | k1 == k2 = vl + | k2 >:> k1 = if isLeft k1 e2 + then search k1 l vl + else search k1 r vl + | otherwise = res + +---------------------------------------------------------------- + +{-| + The 'fromList' function creates a new IP routing table from + a list of a pair of 'IPrange' and value. +-} +fromList :: IP k => [(IPRange k, a)] -> IPRTable k a +fromList = foldl' (\s (k,v) -> insert k v s) empty + +{-| + The 'toList' function creates a list of a pair of 'IPrange' and + value from an IP routing table. +-} +toList :: IP k => IPRTable k a -> [(IPRange k, a)] +toList = foldt toL [] + where + toL Nil xs = xs + toL (Node (Entry _ _ Nothing) _ _) xs = xs + toL (Node (Entry k _ (Just a)) _ _) xs = (k,a) : xs + +---------------------------------------------------------------- + +foldt :: (IPRTable k a -> b -> b) -> b -> IPRTable k a -> b +foldt _ v Nil = v +foldt func v rt@(Node _ l r) = foldt func (foldt func (func rt v) l) r diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, IIJ Innovation Institute Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/iproute.cabal b/iproute.cabal new file mode 100644 --- /dev/null +++ b/iproute.cabal @@ -0,0 +1,26 @@ +Name: iproute +Version: 0.1 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +License-File: LICENSE +Homepage: http://www.mew.org/~kazu/proj/iproute/ +Synopsis: IP Routing Table +Description: IP Routing Table is a tree of IP ranges + to search one of them on the longest + match base. It is a kind of TRIE with one + way branching removed. Both IPv4 and IPv6 + are supported. +Category: Algorithms +Cabal-Version: >= 1.2 +Build-Type: Simple +Extra-Source-Files: test/Tests.hs test/IPv4Search.hs test/Makefile +library + GHC-Options: -Wall + Exposed-Modules: Data.IP + Data.IP.RouteTable + Other-Modules: Data.IP.RouteTable.Internal + Build-Depends: base >= 2.0 && < 4, + parsec >= 2.0, + containers >= 0.2 + diff --git a/test/IPv4Search.hs b/test/IPv4Search.hs new file mode 100644 --- /dev/null +++ b/test/IPv4Search.hs @@ -0,0 +1,39 @@ +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 + putStrLn $ show res + where + handler :: ErrorCall -> IO () + handler _ = help + +loadRoutes :: FilePath -> IO (IPRTable IPv4 (IPRange IPv4)) +loadRoutes file = do + cs <- readFile file + let ls = lines cs + rs = map readIPv4Range ls + kvs = zip rs rs -- value is IPRange itself in this test + radish = fromList kvs + return radish + +readIPv4Range :: String -> IPRange IPv4 +readIPv4Range = read + +help :: IO () +help = do + putStrLn "Usage:" + putStrLn " ipv4_search file IPv4" + diff --git a/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,7 @@ +PROG = ipv4_search + +all: + ghc -Wall -i.. --make -o $(PROG) IPv4Search.hs + +clean: + rm -f *.hi *.o $(PROG) diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances #-} +---------------------------------------------------------------- +-- +-- Tests for IP.RouteTable +-- +-- runghc -i.. Tests.hs +-- + +import Data.IP +import Data.IP.RouteTable.Internal +import Test.QuickCheck hiding (check, test) +import Test.QuickCheck.Batch +import Prelude hiding (lookup) +import Data.List (sort, nub) + +options :: TestOptions +options = TestOptions { no_of_tests = 300 + , length_of_tests = 0 + , debug_tests = False + } + +main :: IO () +main = do + runTests "base" options [ run prop_sort_ipv4 + , run prop_sort_ipv6 + , run prop_fromto_ipv4 + , run prop_fromto_ipv6 + , run prop_search_ipv4 + , run prop_search_ipv6 + , run prop_ord_ipv4 + , run prop_ord_ipv6 + ] + +---------------------------------------------------------------- +-- +-- Arbitrary +-- + +instance Arbitrary (IPRange IPv4) where + arbitrary = arbitraryIP toIPv4 255 4 32 + coarbitrary = undefined + +instance Arbitrary (IPRange IPv6) where + arbitrary = arbitraryIP toIPv6 65535 8 128 + coarbitrary = error "coarbitrary" + +arbitraryIP :: IP a => ([Int] -> a) -> Int -> Int -> Int -> Gen (IPRange a) +arbitraryIP func width adrlen msklen = do + a <- sequence $ take adrlen $ repeat (choose (0,width)) + let adr = func a + len <- choose (0,msklen) + return $ makeIPRange adr len + +---------------------------------------------------------------- +-- +-- Properties +-- + +prop_sort_ipv4 :: [IPRange IPv4] -> Bool +prop_sort_ipv4 = sort_ip + +prop_sort_ipv6 :: [IPRange IPv6] -> Bool +prop_sort_ipv6 = sort_ip + +sort_ip :: (IP a, Ord a) => [IPRange a] -> Bool +sort_ip xs = fromList (zip xs xs) == let xs' = sort xs + in fromList (zip xs' xs') + +---------------------------------------------------------------- + +prop_fromto_ipv4 :: [IPRange IPv4] -> Bool +prop_fromto_ipv4 = fromto_ip + +prop_fromto_ipv6 :: [IPRange IPv6] -> Bool +prop_fromto_ipv6 = fromto_ip + +fromto_ip :: (IP a, Ord a) => [IPRange a] -> Bool +fromto_ip xs = let ys = map fst $ toList $ fromList (zip xs xs) + in nub (sort xs) == nub (sort ys) + +---------------------------------------------------------------- + +prop_ord_ipv4 :: [IPRange IPv4] -> Bool +prop_ord_ipv4 = ord_ip + +prop_ord_ipv6 :: [IPRange IPv6] -> Bool +prop_ord_ipv6 = ord_ip + +ord_ip :: IP a => [IPRange a] -> Bool +ord_ip xs = isOrdered (fromList (zip xs xs)) + +isOrdered :: IP k => IPRTable k a -> Bool +isOrdered = foldt (\x v -> v && ordered x) True + +ordered :: IP k => IPRTable k a -> Bool +ordered Nil = True +ordered (Node n l r) = ordered' n l && ordered' n r + where + ordered' _ Nil = True + ordered' (Entry k1 _ _) (Node (Entry k2 _ _) _ _) = k1 >:> k2 + +---------------------------------------------------------------- + +prop_search_ipv4 :: IPRange IPv4 -> [IPRange IPv4] -> Bool +prop_search_ipv4 = search_ip + +prop_search_ipv6 :: IPRange IPv6 -> [IPRange IPv6] -> Bool +prop_search_ipv6 = search_ip + +search_ip :: IP a => IPRange a -> [IPRange a] -> Bool +search_ip k xs = lookup k (fromList (zip xs xs)) == linear k xs + +linear :: IP a => IPRange a -> [IPRange a] -> Maybe (IPRange 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