iproute 1.2.12 → 1.7.15
raw patch · 15 files changed
Files
- Data/IP.hs +42/−15
- Data/IP/Addr.hs +517/−152
- Data/IP/Builder.hs +330/−0
- Data/IP/Internal.hs +10/−0
- Data/IP/Mask.hs +35/−20
- Data/IP/Op.hs +82/−54
- Data/IP/Range.hs +74/−59
- Data/IP/RouteTable.hs +30/−21
- Data/IP/RouteTable/Internal.hs +261/−149
- Setup.hs +1/−0
- iproute.cabal +79/−58
- test/BuilderSpec.hs +71/−0
- test/IPSpec.hs +28/−1
- test/RouteTableSpec.hs +56/−10
- test/doctests.hs +0/−6
Data/IP.hs view
@@ -1,19 +1,46 @@-{-|- Data structures to express IPv4, IPv6 and IP range.--}+-- |+-- Data structures to express IPv4, IPv6 and IP range. module Data.IP (- -- * Documentation- -- ** IP data- IP (..)- , IPv4, toIPv4, fromIPv4, fromHostAddress, toHostAddress- , IPv6, toIPv6, fromIPv6, fromHostAddress6, toHostAddress6- -- ** IP range data- , IPRange (..)- , AddrRange (addr, mask, mlen)- -- ** Address class- , Addr (..)- , makeAddrRange, (>:>), isMatchedTo- ) where+ -- * IP data+ IP (..),++ -- ** IPv4+ IPv4,+ toIPv4,+ toIPv4w,+ fromIPv4,+ fromIPv4w,+ fromHostAddress,+ toHostAddress,++ -- ** IPv6+ IPv6,+ toIPv6,+ toIPv6b,+ toIPv6w,+ fromIPv6,+ fromIPv6b,+ fromIPv6w,+ fromHostAddress6,+ toHostAddress6,++ -- ** Converters+ ipv4ToIPv6,+ fromSockAddr,+ toSockAddr,++ -- * IP range data+ IPRange (..),+ AddrRange (addr, mask, mlen),++ -- * Address class+ Addr (..),+ makeAddrRange,+ (>:>),+ isMatchedTo,+ addrRangePair,+ ipv4RangeToIPv6,+) where import Data.IP.Addr import Data.IP.Op
Data/IP/Addr.hs view
@@ -1,31 +1,69 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ module Data.IP.Addr where import Control.Monad import Data.Bits import Data.Char-import Data.List (foldl')+import Data.Data (Data)+import Data.List (foldl', intersperse) import Data.String+import Data.Typeable (Typeable) import Data.Word+import GHC.Enum (predError, succError)+import GHC.Generics import Network.Socket+import Numeric (showHex, showInt) import System.ByteOrder import Text.Appar.String-import Text.Printf ---------------------------------------------------------------- -{-|- 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.+-- |+-- 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.+--+-- >>> (read "192.0.2.1" :: IP) == IPv4 (read "192.0.2.1" :: IPv4)+-- True+-- >>> (read "2001:db8:00:00:00:00:00:01" :: IP) == IPv6 (read "2001:db8:00:00:00:00:00:01" :: IPv6)+-- True+data IP+ = IPv4 {ipv4 :: IPv4}+ | IPv6 {ipv6 :: IPv6}+ deriving (Data, Generic, Typeable) ->>> (read "192.0.2.1" :: IP) == IPv4 (read "192.0.2.1" :: IPv4)-True->>> (read "2001:db8:00:00:00:00:00:01" :: IP) == IPv6 (read "2001:db8:00:00:00:00:00:01" :: IPv6)-True--}+-- |+-- Equality over IP addresses. Correctly compare IPv4 and IPv4-embedded-in-IPv6 addresses.+--+-- >>> (read "2001:db8:00:00:00:00:00:01" :: IP) == (read "2001:db8:00:00:00:00:00:01" :: IP)+-- True+-- >>> (read "2001:db8:00:00:00:00:00:01" :: IP) == (read "2001:db8:00:00:00:00:00:05" :: IP)+-- False+-- >>> (read "127.0.0.1" :: IP) == (read "127.0.0.1" :: IP)+-- True+-- >>> (read "127.0.0.1" :: IP) == (read "10.0.0.1" :: IP)+-- False+-- >>> (read "::ffff:127.0.0.1" :: IP) == (read "127.0.0.1" :: IP)+-- True+-- >>> (read "::ffff:127.0.0.1" :: IP) == (read "127.0.0.9" :: IP)+-- False+-- >>> (read "::ffff:127.0.0.1" :: IP) >= (read "127.0.0.1" :: IP)+-- True+-- >>> (read "::ffff:127.0.0.1" :: IP) <= (read "127.0.0.1" :: IP)+-- True+instance Eq IP where+ (IPv4 ip1) == (IPv4 ip2) = ip1 == ip2+ (IPv6 ip1) == (IPv6 ip2) = ip1 == ip2+ (IPv4 ip1) == (IPv6 ip2) = ipv4ToIPv6 ip1 == ip2+ (IPv6 ip1) == (IPv4 ip2) = ip1 == ipv4ToIPv6 ip2 -data IP = IPv4 { ipv4 :: IPv4 }- | IPv6 { ipv6 :: IPv6 }- deriving (Eq, Ord)+instance Ord IP where+ (IPv4 ip1) `compare` (IPv4 ip2) = ip1 `compare` ip2+ (IPv6 ip1) `compare` (IPv6 ip2) = ip1 `compare` ip2+ (IPv4 ip1) `compare` (IPv6 ip2) = ipv4ToIPv6 ip1 `compare` ip2+ (IPv6 ip1) `compare` (IPv4 ip2) = ip1 `compare` ipv4ToIPv6 ip2 instance Show IP where show (IPv4 ip) = show ip@@ -35,121 +73,393 @@ -- This is host byte order type IPv4Addr = Word32-type IPv6Addr = (Word32,Word32,Word32,Word32)+type IPv6Addr = (Word32, Word32, Word32, Word32) -{-|- The abstract data type to express an IPv4 address.- 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.+-- |+-- The abstract data type to express an IPv4 address.+-- 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.+--+-- >>> read "192.0.2.1" :: IPv4+-- 192.0.2.1+newtype IPv4 = IP4 IPv4Addr+ deriving (Eq, Ord, Bounded, Data, Generic, Typeable) ->>> read "192.0.2.1" :: IPv4-192.0.2.1--}-newtype IPv4 = IP4 IPv4Addr deriving (Eq, Ord)+-- |+-- The abstract data type to express an IPv6 address.+-- 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.+--+-- >>> read "2001:db8:00:00:00:00:00:01" :: IPv6+-- 2001:db8::1+-- >>> read "2001:db8:11e:c00::101" :: IPv6+-- 2001:db8:11e:c00::101+-- >>> read "2001:db8:11e:c00:aa:bb:192.0.2.1" :: IPv6+-- 2001:db8:11e:c00:aa:bb:c000:201+-- >>> read "2001:db8::192.0.2.1" :: IPv6+-- 2001:db8::c000:201+-- >>> read "0::ffff:192.0.2.1" :: IPv6+-- ::ffff:192.0.2.1+-- >>> read "0::0:c000:201" :: IPv6+-- ::192.0.2.1+-- >>> read "::0.0.0.1" :: IPv6+-- ::1+newtype IPv6 = IP6 IPv6Addr+ deriving (Eq, Ord, Bounded, Data, Generic, Typeable) -{-|- The abstract data type to express an IPv6 address.- 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.+----------------------------------------------------------------+--+-- Enum+-- ->>> read "2001:db8:00:00:00:00:00:01" :: IPv6-2001:db8:00:00:00:00:00:01->>> read "2001:db8:11e:c00::101" :: IPv6-2001:db8:11e:c00:00:00:00:101->>> read "2001:db8:11e:c00:aa:bb:192.0.2.1" :: IPv6-2001:db8:11e:c00:aa:bb:c000:201->>> read "2001:db8::192.0.2.1" :: IPv6-2001:db8:00:00:00:00:c000:201--}-newtype IPv6 = IP6 IPv6Addr deriving (Eq, Ord)+instance Enum IPv4 where+ fromEnum (IP4 a) = fromEnum a+ toEnum = IP4 . toEnum +instance Enum IPv6 where+ -- fromEnum and toEnum are not really useful, but I defined them anyway+ fromEnum (IP6 (a, b, c, d)) =+ let a' = fromEnum a `shift` 96+ b' = fromEnum b `shift` 64+ c' = fromEnum c `shift` 32+ d' = fromEnum d+ in a' .|. b' .|. c' .|. d'+ toEnum i =+ let i' = fromIntegral i :: Integer+ a = fromIntegral (i' `shiftR` 96 .&. 0xffffffff)+ b = fromIntegral (i' `shiftR` 64 .&. 0xffffffff)+ c = fromIntegral (i' `shiftR` 32 .&. 0xffffffff)+ d = fromIntegral (i' .&. 0xffffffff)+ in IP6 (a, b, c, d)++ succ (IP6 (0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff)) = succError "IPv6"+ succ (IP6 (a, 0xffffffff, 0xffffffff, 0xffffffff)) = IP6 (succ a, 0, 0, 0)+ succ (IP6 (a, b, 0xffffffff, 0xffffffff)) = IP6 (a, succ b, 0, 0)+ succ (IP6 (a, b, c, 0xffffffff)) = IP6 (a, b, succ c, 0)+ succ (IP6 (a, b, c, d)) = IP6 (a, b, c, succ d)++ pred (IP6 (0, 0, 0, 0)) = predError "IPv6"+ pred (IP6 (a, 0, 0, 0)) = IP6 (pred a, 0xffffffff, 0xffffffff, 0xffffffff)+ pred (IP6 (a, b, 0, 0)) = IP6 (a, pred b, 0xffffffff, 0xffffffff)+ pred (IP6 (a, b, c, 0)) = IP6 (a, b, pred c, 0xffffffff)+ pred (IP6 (a, b, c, d)) = IP6 (a, b, c, pred d)++ enumFrom ip = ip : gen ip+ where+ gen i = let i' = succ i in i' : gen i'++ enumFromTo ip ip' = ip : gen ip+ where+ gen i+ | i == ip' = []+ | otherwise = let i' = succ i in i' : gen i'++ -- These two are implemented via the integer enum instance.+ -- A more correct implementation would essentially require+ -- implementing instance Num IPv6, which isn't something+ -- I wanna do. Another approach is to use Word128 to store+ -- an IPv6 address.+ enumFromThen ip ip' = fmap integerToIP6 [ip6ToInteger ip, ip6ToInteger ip' ..]+ enumFromThenTo ip inc fin = fmap integerToIP6 [ip6ToInteger ip, ip6ToInteger inc .. ip6ToInteger fin]++instance Enum IP where+ fromEnum (IPv4 ip) = fromEnum ip+ fromEnum (IPv6 ip) = fromEnum ip++ -- Because Int cannot hold an IPv6 anyway+ toEnum = IPv4 . toEnum++ succ (IPv4 ip) = IPv4 $ succ ip+ succ (IPv6 ip) = IPv6 $ succ ip++ pred (IPv4 ip) = IPv4 $ pred ip+ pred (IPv6 ip) = IPv6 $ pred ip++ enumFrom (IPv4 ip) = fmap IPv4 $ enumFrom ip+ enumFrom (IPv6 ip) = fmap IPv6 $ enumFrom ip++ enumFromTo (IPv4 ip) (IPv4 ip') = fmap IPv4 $ enumFromTo ip ip'+ enumFromTo (IPv6 ip) (IPv6 ip') = fmap IPv6 $ enumFromTo ip ip'+ enumFromTo _ _ = error "enumFromTo: Incompatible IP families"++ enumFromThen (IPv4 ip) (IPv4 ip') = fmap IPv4 $ enumFromThen ip ip'+ enumFromThen (IPv6 ip) (IPv6 ip') = fmap IPv6 $ enumFromThen ip ip'+ enumFromThen _ _ = error "enumFromThen: Incompatible IP families"++ enumFromThenTo (IPv4 ip) (IPv4 inc) (IPv4 fin) = fmap IPv4 $ enumFromThenTo ip inc fin+ enumFromThenTo (IPv6 ip) (IPv6 inc) (IPv6 fin) = fmap IPv6 $ enumFromThenTo ip inc fin+ enumFromThenTo _ _ _ = error "enumFromThenTo: Incompatible IP families"++ip6ToInteger :: IPv6 -> Integer+ip6ToInteger (IP6 (a, b, c, d)) =+ let a' = word32ToInteger a `shift` 96+ b' = word32ToInteger b `shift` 64+ c' = word32ToInteger c `shift` 32+ d' = word32ToInteger d+ in a' .|. b' .|. c' .|. d'+ where+ word32ToInteger :: Word32 -> Integer+ word32ToInteger = toEnum . fromEnum++integerToIP6 :: Integer -> IPv6+integerToIP6 i =+ let a = integerToWord32 (i `shiftR` 96 .&. 0xffffffff)+ b = integerToWord32 (i `shiftR` 64 .&. 0xffffffff)+ c = integerToWord32 (i `shiftR` 32 .&. 0xffffffff)+ d = integerToWord32 (i .&. 0xffffffff)+ in IP6 (a, b, c, d)+ where+ integerToWord32 :: Integer -> Word32+ integerToWord32 = toEnum . fromEnum+ ---------------------------------------------------------------- -- -- Show -- instance Show IPv4 where- show = showIPv4+ show ip = showIPv4 ip "" instance Show IPv6 where- show = showIPv6+ show ip = showIPv6 ip "" -showIPv4 :: IPv4 -> String-showIPv4 (IP4 a) = show4 a- where- remQuo x = (x `mod` 256, x `div` 256)- show4 q = printf "%d.%d.%d.%d" a1 a2 a3 a4- where- (a4,q4) = remQuo q- (a3,q3) = remQuo q4- (a2,q2) = remQuo q3- (a1, _) = remQuo q2+-- | Show an IPv4 address in the dot-decimal notation.+showIPv4 :: IPv4 -> ShowS+showIPv4 = foldr1 (.) . intersperse (showChar '.') . map showInt . fromIPv4 -showIPv6 :: IPv6 -> String-showIPv6 (IP6 (a1,a2,a3,a4)) = show6 a1 ++ ":" ++ show6 a2 ++ ":" ++ show6 a3 ++ ":" ++ show6 a4+-- | Show an IPv6 address in the most appropriate notation, based on recommended+-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>.+--+-- /The implementation is completely compatible with the current implementation+-- of the `inet_ntop` function in glibc./+showIPv6 :: IPv6 -> ShowS+showIPv6 ip@(IP6 (a1, a2, a3, a4))+ -- IPv4-Mapped IPv6 Address+ | a1 == 0 && a2 == 0 && a3 == 0xffff =+ showString "::ffff:" . showIPv4 (IP4 a4)+ -- IPv4-Compatible IPv6 Address (exclude IPRange ::/112)+ | a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 =+ showString "::" . showIPv4 (IP4 a4)+ -- length of longest run > 1, replace it with "::"+ | end - begin > 1 =+ showFields prefix . showString "::" . showFields suffix+ -- length of longest run <= 1, don't use "::"+ | otherwise =+ showFields fields where- remQuo x = (x `mod` 65536, x `div` 65536)- show6 q = printf "%02x:%02x" r1 r2- where- (r2,q2) = remQuo q- (r1, _) = remQuo q2+ fields = fromIPv6 ip+ showFields = foldr (.) id . intersperse (showChar ':') . map showHex+ prefix = take begin fields -- fields before "::"+ suffix = drop end fields -- fields after "::"+ begin = end + diff -- the longest run of zeros+ (diff, end) =+ minimum $+ scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0 ..] ---------------------------------------------------------------- -- -- IntToIP -- -{-|- The 'toIPv4' function takes a list of 'Int' and returns 'IPv4'.-->>> toIPv4 [192,0,2,1]-192.0.2.1--}+-- |+-- The 'toIPv4' function returns the 'IPv4' address corresponding to the given+-- list of 'Int' octets. The function is strict in the four elements of the+-- list. An error is returned if the list has a differnet length. The input+-- elements are silently truncated to their 8 least-significant bits before they+-- are combined to form the IPv4 address.+--+-- >>> toIPv4 [192,0,2,1]+-- 192.0.2.1 toIPv4 :: [Int] -> IPv4-toIPv4 = IP4 . toWord32+toIPv4 [a1, a2, a3, a4] = IP4 w where- toWord32 [a1,a2,a3,a4] = fromIntegral $ shift a1 24 + shift a2 16 + shift a3 8 + a4- toWord32 _ = error "toWord32"+ w =+ (fromIntegral a1 .&. 0xff) `unsafeShiftL` 24+ .|. (fromIntegral a2 .&. 0xff) `unsafeShiftL` 16+ .|. (fromIntegral a3 .&. 0xff) `unsafeShiftL` 8+ .|. (fromIntegral a4 .&. 0xff)+toIPv4 _ = error "IPv4 field list length != 4"+{-# INLINE toIPv4 #-} -{-|- The 'toIPv6' function takes a list of 'Int' and returns 'IPv6'.+-- |+-- The 'toIPv4w' function constructs the 'IPv4' address corresponding to the+-- given 'Word32' value. Unlike the 'fromHostAddress' function, it is strict in+-- the input value, which here is in host byte order.+--+-- >>> toIPv4w 0xc0000201+-- 192.0.2.1+--+-- @since 1.7.9+toIPv4w :: Word32 -> IPv4+toIPv4w w = IP4 w+{-# INLINE toIPv4w #-} ->>> toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]-2001:db8:00:00:00:00:00:01--}+-- |+-- The 'toIPv6' function returns the 'IPv6' address corresponding to the given+-- list of eight 16-bit 'Int's. The function is strict in the eight elements of+-- the list. An error is returned if the list has a differnet length. The+-- input elements are in host byte order and are silently truncated to their 16+-- least-signicant bits before they are combined to form the IPv6 address.+--+-- >>> toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]+-- 2001:db8::1 toIPv6 :: [Int] -> IPv6-toIPv6 ad = IP6 (x1,x2,x3,x4)+toIPv6 [i1, i2, i3, i4, i5, i6, i7, i8] = IP6 (x1, x2, x3, x4) where- [x1,x2,x3,x4] = map toWord32 $ split2 ad- split2 [] = []- split2 x = take 2 x : split2 (drop 2 x)- toWord32 [a1,a2] = fromIntegral $ shift a1 16 + a2- toWord32 _ = error "toWord32"+ !x1 = fromIntegral $ (i1 .&. 0xffff) `unsafeShiftL` 16 .|. (i2 .&. 0xffff)+ !x2 = fromIntegral $ (i3 .&. 0xffff) `unsafeShiftL` 16 .|. (i4 .&. 0xffff)+ !x3 = fromIntegral $ (i5 .&. 0xffff) `unsafeShiftL` 16 .|. (i6 .&. 0xffff)+ !x4 = fromIntegral $ (i7 .&. 0xffff) `unsafeShiftL` 16 .|. (i8 .&. 0xffff)+toIPv6 _ = error "toIPv6 field list length != 8"+{-# INLINE toIPv6 #-} +-- |+-- The 'toIPv6b' function returns the IPv6 address corresponding to the given+-- list of sixteen 'Int' octets. The function is strict in the sixteen elements+-- of the list. An error is returned if the list has a differnet length. The+-- input elements are silently truncated to their 8 least-signicant bits before+-- they are combined to form the IPv6 address.+--+-- >>> toIPv6b [0x20,0x01,0xD,0xB8,0,0,0,0,0,0,0,0,0,0,0,1]+-- 2001:db8::1+toIPv6b :: [Int] -> IPv6+toIPv6b+ [ h11+ , h12+ , l11+ , l12+ , h21+ , h22+ , l21+ , l22+ , h31+ , h32+ , l31+ , l32+ , h41+ , h42+ , l41+ , l42+ ] = IP6 (x1, x2, x3, x4)+ where+ !x1 =+ fromIntegral $+ (h11 .&. 0xff) `unsafeShiftL` 24+ .|. (h12 .&. 0xff) `unsafeShiftL` 16+ .|. (l11 .&. 0xff) `unsafeShiftL` 8+ .|. (l12 .&. 0xff)+ !x2 =+ fromIntegral $+ (h21 .&. 0xff) `unsafeShiftL` 24+ .|. (h22 .&. 0xff) `unsafeShiftL` 16+ .|. (l21 .&. 0xff) `unsafeShiftL` 8+ .|. (l22 .&. 0xff)+ !x3 =+ fromIntegral $+ (h31 .&. 0xff) `unsafeShiftL` 24+ .|. (h32 .&. 0xff) `unsafeShiftL` 16+ .|. (l31 .&. 0xff) `unsafeShiftL` 8+ .|. (l32 .&. 0xff)+ !x4 =+ fromIntegral $+ (h41 .&. 0xff) `unsafeShiftL` 24+ .|. (h42 .&. 0xff) `unsafeShiftL` 16+ .|. (l41 .&. 0xff) `unsafeShiftL` 8+ .|. (l42 .&. 0xff)+toIPv6b _ = error "toIPv6b field list length != 16"++-- |+-- The 'toIPv6w' function constructs the 'IPv6' address corresponding to the+-- given four-tuple of host byte order 'Word32' values. This function differs+-- from the 'fromHostAddress6' function only in the fact that it is strict in+-- the elements of the tuple.+--+-- >>> toIPv6w (0x20010DB8,0x0,0x0,0x1)+-- 2001:db8::1+--+-- @since 1.7.9+toIPv6w :: (Word32, Word32, Word32, Word32) -> IPv6+toIPv6w w@(!_, !_, !_, !_) = IP6 w+{-# INLINE toIPv6w #-}+ ---------------------------------------------------------------- -- -- IPToInt -- -{-|- The 'fromIPv4' function converts 'IPv4' to a list of 'Int'.-->>> fromIPv4 (toIPv4 [192,0,2,1])-[192,0,2,1]--}+-- |+-- The 'fromIPv4' function returns the list of four 'Int' octets corresponding+-- to the given 'IPv4' address.+--+-- >>> fromIPv4 (toIPv4 [192,0,2,1])+-- [192,0,2,1] fromIPv4 :: IPv4 -> [Int]-fromIPv4 (IP4 w) = map (\n -> fromEnum $ (w `shiftR` n) .&. 0xff) [0o30, 0o20, 0o10, 0o00]+fromIPv4 (IP4 w) = split w 0o30 : split w 0o20 : split w 0o10 : split w 0 : []+ where+ split :: Word32 -> Int -> Int+ split a n = fromIntegral $ a `unsafeShiftR` n .&. 0xff+{-# INLINE fromIPv4 #-} -{-|- The 'toIPv6' function converts 'IPv6' to a list of 'Int'.+-- |+-- The 'fromIPv4w' function returns a single 'Word32' value corresponding to the+-- given the 'IPv4' address. Unlike the 'toHostAddress' function, the returned+-- value is strictly evaluated, and is not converted to network byte order.+--+-- >>> fromIPv4w (toIPv4 [0xc0,0,2,1]) == 0xc0000201+-- True+--+-- @since 1.7.9+fromIPv4w :: IPv4 -> Word32+fromIPv4w (IP4 !ip4rep) = ip4rep+{-# INLINE fromIPv4w #-} ->>> fromIPv6 (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1])-[8193,3512,0,0,0,0,0,1]--}+-- |+-- The 'fromIPv6' function returns a list eight 'Int's in host byte order+-- corresponding to the eight 16-bit fragments of the given IPv6 address.+--+-- >>> fromIPv6 (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1])+-- [8193,3512,0,0,0,0,0,1] fromIPv6 :: IPv6 -> [Int]-fromIPv6 (IP6 (w1, w2, w3, w4)) = map fromEnum (concatMap split [w1,w2,w3,w4])+fromIPv6 (IP6 (w1, w2, w3, w4)) =+ split w1 . split w2 . split w3 . split w4 $ [] where- split :: Word32 -> [Word32]- split n = [n `shiftR` 0x10 .&. 0xffff, n .&. 0xffff]+ split :: Word32 -> [Int] -> [Int]+ split n acc =+ fromIntegral (n `unsafeShiftR` 0x10 .&. 0xffff)+ : fromIntegral (n .&. 0xffff)+ : acc+{-# INLINE fromIPv6 #-} +-- |+-- The 'fromIPv6b' function returns the 16 'Int' octets corresponding+-- to the 16 bytes of the given IPv6 address.+--+-- >>> fromIPv6b (toIPv6b [0x20,0x01,0xD,0xB8,0,0,0,0,0,0,0,0,0,0,0,1])+-- [32,1,13,184,0,0,0,0,0,0,0,0,0,0,0,1]+fromIPv6b :: IPv6 -> [Int]+fromIPv6b (IP6 (w1, w2, w3, w4)) =+ split w1 . split w2 . split w3 . split w4 $ []+ where+ split :: Word32 -> [Int] -> [Int]+ split n acc =+ fromIntegral (n `unsafeShiftR` 24 .&. 0xff)+ : fromIntegral (n `unsafeShiftR` 16 .&. 0xff)+ : fromIntegral (n `unsafeShiftR` 8 .&. 0xff)+ : fromIntegral (n .&. 0xff)+ : acc++-- |+-- The 'fromIPv6w' function returns a four-tuple of 'Word32' values in host byte+-- order corresponding to the given 'IPv6' address. This is identical to the+-- 'toHostAddress6' function, except that the elements of four-tuple are+-- first strictly evaluated.+--+-- >>> fromIPv6w (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) == (0x20010DB8, 0, 0, 1)+-- True+--+-- @since 1.7.9+fromIPv6w :: IPv6 -> (Word32, Word32, Word32, Word32)+fromIPv6w (IP6 ip6rep) = ip6rep+{-# INLINE fromIPv6w #-}+ ---------------------------------------------------------------- -- -- Read@@ -164,22 +474,22 @@ instance Read IPv6 where readsPrec _ = parseIPv6 -parseIP :: String -> [(IP,String)]+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,_) -> []+ (Just ip, rest) -> [(IPv4 ip, rest)]+ (Nothing, _) -> case runParser ip6 cs of+ (Just ip, rest) -> [(IPv6 ip, rest)]+ (Nothing, _) -> [] -parseIPv4 :: String -> [(IPv4,String)]+parseIPv4 :: String -> [(IPv4, String)] parseIPv4 cs = case runParser ip4 cs of- (Nothing,_) -> []- (Just a4,rest) -> [(a4,rest)]+ (Nothing, _) -> []+ (Just a4, rest) -> [(a4, rest)] -parseIPv6 :: String -> [(IPv6,String)]+parseIPv6 :: String -> [(IPv6, String)] parseIPv6 cs = case runParser ip6 cs of- (Nothing,_) -> []- (Just a6,rest) -> [(a6,rest)]+ (Nothing, _) -> []+ (Just a6, rest) -> [(a6, rest)] ---------------------------------------------------------------- --@@ -200,30 +510,41 @@ -- IPv4 Parser -- -dig :: Parser Int-dig = 0 <$ char '0'- <|> toInt <$> oneOf ['1'..'9'] <*> many digit+octet :: Parser Int+octet =+ 0 <$ char '0'+ <|> (toInt =<< (:) <$> oneOf ['1' .. '9'] <*> many digit) where- toInt n ns = foldl' (\x y -> x * 10 + y) 0 . map digitToInt $ n : ns+ toInt ds = maybe (fail "IPv4 address") pure $ foldr go Just ds 0+ go !d !f !n =+ let n' = n * 10 + ord d - 48+ in if n' <= 255 then f n' else Nothing ip4 :: Parser IPv4-ip4 = skipSpaces >> toIPv4 <$> ip4'+ip4 = skipSpaces >> toIPv4 <$> ip4' True -ip4' :: Parser [Int]-ip4' = do- as <- dig `sepBy1` char '.'- check as+ip4' :: Bool -> Parser [Int]+ip4' checkTermination = do+ a0 <- octet+ _ <- char '.'+ a1 <- octet+ _ <- char '.'+ a2 <- octet+ _ <- char '.'+ a3 <- octet+ let as = [a0, a1, a2, a3]+ when checkTermination $+ skipSpaces >> termination return as- where- test errmsg adr = when (adr < 0 || 255 < adr) (fail errmsg)- check as = do- let errmsg = "IPv4 adddress"- when (length as /= 4) (fail errmsg)- mapM_ (test errmsg) as skipSpaces :: Parser () skipSpaces = void $ many (char ' ') +termination :: Parser ()+termination = P $ \str -> case str of+ [] -> (Just (), "")+ _ -> (Nothing, str)+ ---------------------------------------------------------------- -- -- IPv6 Parser (RFC 4291)@@ -254,44 +575,67 @@ return $ bs1 ++ spring ++ bs2 ip6 :: Parser IPv6-ip6 = skipSpaces >> toIPv6 <$> ip6'+ip6 = ip6' True -ip6' :: Parser [Int]-ip6' = ip4Embedded- <|> do colon2- bs <- option [] hexcolon- format [] bs- <|> try (do rs <- hexcolon- check rs- return rs)- <|> do bs1 <- hexcolon2- bs2 <- option [] hexcolon- format bs1 bs2+ip6' :: Bool -> Parser IPv6+ip6' checkTermination = skipSpaces >> toIPv6 <$> ip6arr where- hexcolon = hex `sepBy1` char ':'- hexcolon2 = manyTill (hex <* char ':') (char ':')- check bs = when (length bs /= 8) (fail "IPv6 address4")+ ip6arr =+ ip4Embedded' checkTermination+ <|> do+ colon2+ bs <- option [] hexcolon+ format [] bs+ <|> try+ ( do+ rs <- hexcolon+ check rs+ return rs+ )+ <|> do+ bs1 <- hexcolon2+ bs2 <- option [] hexcolon+ format bs1 bs2+ where+ hexcolon = hex `sepBy1` char ':'+ hexcolon2 = manyTill (hex <* char ':') (char ':')+ check bs = when (length bs /= 8) (fail "IPv6 address4") ip4Embedded :: Parser [Int]-ip4Embedded = try (do colon2- bs <- beforeEmbedded- embedded <- ip4'- format [] (bs ++ ip4ToIp6 embedded))- -- matches 2001:db8::192.0.2.1- <|> try (do bs1 <- manyTill (try $ hex <* char ':') (char ':')- bs2 <- option [] beforeEmbedded- embedded <- ip4'- format bs1 (bs2 ++ ip4ToIp6 embedded))- -- matches 2001:db8:11e:c00:aa:bb:192.0.2.1- <|> try (do bs <- beforeEmbedded- embedded <- ip4'- let rs = bs ++ ip4ToIp6 embedded- check rs- return rs)+ip4Embedded = ip4Embedded' True++ip4Embedded' :: Bool -> Parser [Int]+ip4Embedded' checkTermination =+ try+ ( do+ colon2+ bs <- beforeEmbedded+ embedded <- ip4' checkTermination+ format [] (bs ++ ip4ToIp6 embedded)+ )+ -- matches 2001:db8::192.0.2.1+ <|> try+ ( do+ bs1 <- manyTill (try $ hex <* char ':') (char ':')+ bs2 <- option [] beforeEmbedded+ embedded <- ip4' checkTermination+ format bs1 (bs2 ++ ip4ToIp6 embedded)+ )+ -- matches 2001:db8:11e:c00:aa:bb:192.0.2.1+ <|> try+ ( do+ bs <- beforeEmbedded+ embedded <- ip4' checkTermination+ let rs = bs ++ ip4ToIp6 embedded+ check rs+ return rs+ ) where beforeEmbedded = many $ try $ hex <* char ':'- ip4ToIp6 [a,b,c,d] = [ a `shiftL` 8 .|. b- , c `shiftL` 8 .|. d ]+ ip4ToIp6 [a, b, c, d] =+ [ a `shiftL` 8 .|. b+ , c `shiftL` 8 .|. d+ ] ip4ToIp6 _ = error "ip4ToIp6" check bs = when (length bs /= 8) (fail "IPv6 address4") @@ -303,14 +647,14 @@ -- | The 'fromHostAddress' function converts 'HostAddress' to 'IPv4'. fromHostAddress :: HostAddress -> IPv4 fromHostAddress addr4- | byteOrder == LittleEndian = IP4 $ fixByteOrder addr4- | otherwise = IP4 addr4+ | byteOrder == LittleEndian = IP4 $ fixByteOrder addr4+ | otherwise = IP4 addr4 -- | The 'toHostAddress' function converts 'IPv4' to 'HostAddress'. toHostAddress :: IPv4 -> HostAddress toHostAddress (IP4 addr4)- | byteOrder == LittleEndian = fixByteOrder addr4- | otherwise = addr4+ | byteOrder == LittleEndian = fixByteOrder addr4+ | otherwise = addr4 -- | The 'fromHostAddress6' function converts 'HostAddress6' to 'IPv6'. fromHostAddress6 :: HostAddress6 -> IPv6@@ -324,6 +668,27 @@ fixByteOrder s = d1 .|. d2 .|. d3 .|. d4 where d1 = shiftL s 24- d2 = shiftL s 8 .&. 0x00ff0000- d3 = shiftR s 8 .&. 0x0000ff00+ d2 = shiftL s 8 .&. 0x00ff0000+ d3 = shiftR s 8 .&. 0x0000ff00 d4 = shiftR s 24 .&. 0x000000ff++-- | Convert IPv4 address to IPv4-embedded-in-IPv6+ipv4ToIPv6 :: IPv4 -> IPv6+ipv4ToIPv6 ip = toIPv6b [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0xff, 0xff, i1, i2, i3, i4]+ where+ [i1, i2, i3, i4] = fromIPv4 ip++-- | Convert 'SockAddr' to 'IP'.+--+-- Since: 1.7.4.+fromSockAddr :: SockAddr -> Maybe (IP, PortNumber)+fromSockAddr (SockAddrInet pn ha) = Just (IPv4 (fromHostAddress ha), pn)+fromSockAddr (SockAddrInet6 pn _ ha6 _) = Just (IPv6 (fromHostAddress6 ha6), pn)+fromSockAddr _ = Nothing++-- | Convert 'IP' to 'SockAddr'.+--+-- Since: 1.7.8.+toSockAddr :: (IP, PortNumber) -> SockAddr+toSockAddr (IPv4 addr4, pn) = SockAddrInet pn (toHostAddress addr4)+toSockAddr (IPv6 addr6, pn) = SockAddrInet6 pn 0 (toHostAddress6 addr6) 0
+ Data/IP/Builder.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoStrict #-}++module Data.IP.Builder (+ -- * 'P.BoundedPrim' 'B.Builder's for general, IPv4 and IPv6 addresses.+ ipBuilder,+ ipv4Builder,+ ipv6Builder,+) where++import qualified Data.ByteString.Builder as B+import Data.ByteString.Builder.Prim ((>$<), (>*<))+import qualified Data.ByteString.Builder.Prim as P+import GHC.Exts+import GHC.Word (Word16 (..), Word32 (..), Word8 (..))++import Data.IP.Addr++------------ IP builders++{-# INLINE ipBuilder #-}++-- | 'P.BoundedPrim' bytestring 'B.Builder' for general 'IP' addresses.+ipBuilder :: IP -> B.Builder+ipBuilder (IPv4 addr) = ipv4Builder addr+ipBuilder (IPv6 addr) = ipv6Builder addr++{-# INLINE ipv4Builder #-}++-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv4' addresses.+ipv4Builder :: IPv4 -> B.Builder+ipv4Builder addr = P.primBounded ipv4Bounded $! fromIPv4w addr++{-# INLINE ipv6Builder #-}++-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv6' addresses.+ipv6Builder :: IPv6 -> B.Builder+ipv6Builder addr = P.primBounded ipv6Bounded $! fromIPv6w addr++------------ Builder utilities++-- Convert fixed to bounded for fusion+toB :: P.FixedPrim a -> P.BoundedPrim a+toB = P.liftFixedToBounded+{-# INLINE toB #-}++ipv4Bounded :: P.BoundedPrim Word32+ipv4Bounded =+ quads+ >$< ((P.word8Dec >*< dotsep) >*< (P.word8Dec >*< dotsep))+ >*< ((P.word8Dec >*< dotsep) >*< P.word8Dec)+ where+ quads a = ((qdot 0o30# a, qdot 0o20# a), (qdot 0o10# a, qfin a))+ {-# INLINE quads #-}+ qdot s (W32# a) =+ ( W8#+ (wordToWord8Compat# ((word32ToWordCompat# a `uncheckedShiftRL#` s) `and#` 0xff##))+ , ()+ )+ {-# INLINE qdot #-}+ qfin (W32# a) = W8# (wordToWord8Compat# (word32ToWordCompat# a `and#` 0xff##))+ {-# INLINE qfin #-}+ dotsep = const 0x2e >$< toB P.word8++-- | For each 32-bit chunk of an IPv6 address, encode its display format in the+-- presentation form of the address, based on its location relative to the+-- "best gap", i.e. the left-most longest run of zeros. The "hi" (H) and/or+-- "lo" (L) 16 bits may be accompanied by colons (C) on the left and/or right.+data FF+ = -- | :<h>:<l>+ CHL Word32+ | -- | <h>:<l>+ HL Word32+ | -- | nop+ NOP+ | -- | :+ COL+ | -- | : :+ CC+ | -- | :<l>+ CLO Word32+ | -- | :<h>:+ CHC Word32+ | -- | <h>:+ HC Word32++-- Build an IPv6 address in conformance with+-- [RFC5952](http://tools.ietf.org/html/rfc5952 RFC 5952).+--+ipv6Bounded :: P.BoundedPrim (Word32, Word32, Word32, Word32)+ipv6Bounded =+ P.condB+ generalCase+ (genFields >$< output128)+ ( P.condB+ v4mapped+ ( pairPair+ >$< (colsep >*< colsep)+ >*< (ffff >*< (fstUnit >$< colsep >*< ipv4Bounded))+ )+ (pairPair >$< (P.emptyB >*< colsep) >*< (colsep >*< ipv4Bounded))+ )+ where+ -- The boundedPrim switches and predicates need to be inlined for best+ -- performance, gaining a factor of ~2 in throughput in tests.+ --+ {-# INLINE output128 #-}+ {-# INLINE output64 #-}+ {-# INLINE generalCase #-}+ {-# INLINE v4mapped #-}+ {-# INLINE output32 #-}++ generalCase :: (Word32, Word32, Word32, Word32) -> Bool+ generalCase (w0, w1, w2, w3) =+ w0 /= 0 || w1 /= 0 || (w2 /= 0xffff && (w2 /= 0 || w3 <= 0xffff))+ --+ v4mapped :: (Word32, Word32, Word32, Word32) -> Bool+ v4mapped (w0, w1, w2, _) =+ w0 == 0 && w1 == 0 && w2 == 0xffff++ -- BoundedPrim for the full 128-bit IPv6 address given as+ -- a pair of pairs of FF values, which encode the+ -- output format of each of the 32-bit chunks.+ --+ output128 :: P.BoundedPrim ((FF, FF), (FF, FF))+ output128 = output64 >*< output64+ output64 = (output32 >*< output32)+ --+ -- And finally the per-word case-work.+ --+ output32 :: P.BoundedPrim FF+ output32 =+ P.condB (\case CHL _ -> True; _ -> False) build_CHL $ -- :hi:lo+ P.condB (\case HL _ -> True; _ -> False) build_HL $ -- hi:lo+ P.condB (\case NOP -> True; _ -> False) build_NOP $ --+ P.condB (\case COL -> True; _ -> False) build_COL $ -- :+ P.condB (\case CC -> True; _ -> False) build_CC $ -- : :+ P.condB (\case CLO _ -> True; _ -> False) build_CLO $ -- :lo+ P.condB (\case CHC _ -> True; _ -> False) build_CHC $ -- :hi:+ build_HC -- hi:++ -- encoders for the eight field format (FF) cases.+ --+ build_CHL =+ ( \case+ CHL w -> (fstUnit (hi16 w), fstUnit (lo16 w))+ _ -> undefined+ )+ >$< (colsep >*< P.word16Hex)+ >*< (colsep >*< P.word16Hex)+ --+ build_HL =+ ( \case+ HL w -> (hi16 w, fstUnit (lo16 w))+ _ -> undefined+ )+ >$< P.word16Hex >*< colsep >*< P.word16Hex+ --+ build_NOP = P.emptyB+ --+ build_COL = const () >$< colsep+ --+ build_CC = const ((), ()) >$< colsep >*< colsep+ --+ build_CLO =+ ( \case+ CLO w -> fstUnit (lo16 w)+ _ -> undefined+ )+ >$< colsep >*< P.word16Hex+ --+ build_CHC =+ ( \case+ CHC w -> fstUnit (sndUnit (hi16 w))+ _ -> undefined+ )+ >$< colsep >*< P.word16Hex >*< colsep+ --+ build_HC =+ ( \case+ HC w -> sndUnit (hi16 w)+ _ -> undefined+ )+ >$< P.word16Hex >*< colsep++ -- static encoders+ --+ colsep :: P.BoundedPrim a+ colsep = toB $ const 0x3a >$< P.word8+ --+ ffff :: P.BoundedPrim a+ ffff = toB $ const 0xffff >$< P.word16HexFixed++ -- \| Helpers+ hi16, lo16 :: Word32 -> Word16+ hi16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `uncheckedShiftRL#` 16#))+ lo16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `and#` 0xffff##))+ --+ fstUnit :: a -> ((), a)+ fstUnit = ((),)+ --+ sndUnit :: a -> (a, ())+ sndUnit = (,())+ --+ pairPair (a, b, c, d) = ((a, b), (c, d))++ -- Construct fields decorated with output format details+ genFields (w0, w1, w2, w3) =+ let !(!gapStart, !gapEnd) = bestgap w0 w1 w2 w3+ !f0 = makeF0 gapStart gapEnd w0+ !f1 = makeF12 gapStart gapEnd 2# 3# w1+ !f2 = makeF12 gapStart gapEnd 4# 5# w2+ !f3 = makeF3 gapStart gapEnd w3+ in ((f0, f1), (f2, f3))++ makeF0 (I# gapStart) (I# gapEnd) !w =+ case (gapEnd ==# 0#) `orI#` (gapStart ># 1#) of+ 1# -> HL w+ _ -> case gapStart ==# 0# of+ 1# -> COL+ _ -> HC w+ {-# INLINE makeF0 #-}++ makeF12 (I# gapStart) (I# gapEnd) il ir !w =+ case (gapEnd <=# il) `orI#` (gapStart ># ir) of+ 1# -> CHL w+ _ -> case gapStart >=# il of+ 1# -> case gapStart ==# il of+ 1# -> COL+ _ -> CHC w+ _ -> case gapEnd ==# ir of+ 0# -> NOP+ _ -> CLO w+ {-# INLINE makeF12 #-}++ makeF3 (I# gapStart) (I# gapEnd) !w =+ case gapEnd <=# 6# of+ 1# -> CHL w+ _ -> case gapStart ==# 6# of+ 0# -> case gapEnd ==# 8# of+ 1# -> COL+ _ -> CLO w+ _ -> CC+ {-# INLINE makeF3 #-}++-- | Unrolled and inlined calculation of the first longest+-- run (gap) of 16-bit aligned zeros in the input address.+bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)+bestgap !(W32# a0) !(W32# a1) !(W32# a2) !(W32# a3) =+ finalGap+ ( updateGap+ (0xffff## `and#` (word32ToWordCompat# a3))+ ( updateGap+ (0xffff0000## `and#` (word32ToWordCompat# a3))+ ( updateGap+ (0xffff## `and#` (word32ToWordCompat# a2))+ ( updateGap+ (0xffff0000## `and#` (word32ToWordCompat# a2))+ ( updateGap+ (0xffff## `and#` (word32ToWordCompat# a1))+ ( updateGap+ (0xffff0000## `and#` (word32ToWordCompat# a1))+ ( updateGap+ (0xffff## `and#` (word32ToWordCompat# a0))+ (initGap (0xffff0000## `and#` (word32ToWordCompat# a0)))+ )+ )+ )+ )+ )+ )+ )+ where+ -- The state after the first input word is always i' = 7,+ -- but if the input word is zero, then also g=z=1 and e'=7.+ initGap :: Word# -> Int#+ initGap w = case w of 0## -> 0x1717#; _ -> 0x0707#++ -- Update the nibbles of g|e'|z|i' based on the next input+ -- word. We always decrement i', reset z on non-zero input,+ -- otherwise increment z and check for a new best gap, if so+ -- we replace g|e' with z|i'.+ updateGap :: Word# -> Int# -> Int#+ updateGap w g = case w `neWord#` 0## of+ 1# -> (g +# 0xffff#) `andI#` 0xff0f# -- g, e, 0, --i+ _ ->+ let old = g +# 0xf# -- ++z, --i+ zi = old `andI#` 0xff#+ new = (zi `uncheckedIShiftL#` 8#) `orI#` zi+ in case new ># old of+ 1# -> new -- z, i, z, i+ _ -> old -- g, e, z, i++ -- Extract gap start and end from the nibbles of g|e'|z|i'+ -- where g is the gap width and e' is 8 minus its end.+ finalGap :: Int# -> (Int, Int)+ finalGap i =+ let g = i `uncheckedIShiftRL#` 12#+ in case g <# 2# of+ 1# -> (0, 0)+ _ ->+ let e = 8# -# ((i `uncheckedIShiftRL#` 8#) `andI#` 0xf#)+ s = e -# g+ in (I# s, I# e)+{-# INLINE bestgap #-}++#if MIN_VERSION_base(4,16,0)+word32ToWordCompat# :: Word32# -> Word#+word32ToWordCompat# = word32ToWord#++wordToWord8Compat# :: Word# -> Word8#+wordToWord8Compat# = wordToWord8#++wordToWord16Compat# :: Word# -> Word16#+wordToWord16Compat# = wordToWord16#+#else+word32ToWordCompat# :: Word# -> Word#+word32ToWordCompat# x = x++wordToWord8Compat# :: Word# -> Word#+wordToWord8Compat# x = x++wordToWord16Compat# :: Word# -> Word#+wordToWord16Compat# x = x+#endif
+ Data/IP/Internal.hs view
@@ -0,0 +1,10 @@+module Data.IP.Internal (+ IPv4 (..),+ IPv6 (..),+ AddrRange (..),+ IPv4Addr,+ IPv6Addr,+) where++import Data.IP.Addr+import Data.IP.Range
Data/IP/Mask.hs view
@@ -3,31 +3,46 @@ import Data.Bits import Data.IP.Addr import Data.Word-import Data.IntMap hiding (map) ------------------------------------------------------------------ maskIPv4 :: Int -> IPv4-maskIPv4 len = IP4 (masksIPv4 ! len)+maskIPv4 len =+ IP4 $ complement $ 0xffffffff `shift` (-len) maskIPv6 :: Int -> IPv6-maskIPv6 len = IP6 (masksIPv6 ! len)+maskIPv6 len =+ IP6 $+ toIP6Addr $+ bimapTup complement $+ (0xffffffffffffffff, 0xffffffffffffffff) `shift128` (-len)+ where+ bimapTup f (x, y) = (f x, f y) -masksWord32 :: [Word32]-masksWord32 = take 33 $ iterate (`shift` 1) 0xffffffff+shift128 :: (Word64, Word64) -> Int -> (Word64, Word64)+shift128 x i+ | i < 0 = x `shiftR128` (-i)+ | i > 0 = x `shiftL128` i+ | otherwise = x -masksIPv4 :: IntMap IPv4Addr-masksIPv4 = fromList $ zip [32,31..0] masksWord32+shiftL128 :: (Word64, Word64) -> Int -> (Word64, Word64)+shiftL128 (h, l) i =+ ((h `shiftL` i) .|. (l `shift` (i - 64)), (l `shiftL` i)) -masksIPv6 :: IntMap IPv6Addr-masksIPv6 = fromList $ zip [128,127..0] ms+shiftR128 :: (Word64, Word64) -> Int -> (Word64, Word64)+shiftR128 (h, l) i =+ (h `shiftR` i, (l `shiftR` i) .|. h `shift` (64 - i))++fromIP6Addr :: IPv6Addr -> (Word64, Word64)+fromIP6Addr (w3, w2, w1, w0) =+ ( (fromIntegral w3 `shiftL` 32) .|. fromIntegral w2+ , (fromIntegral w1 `shiftL` 32) .|. fromIntegral w0+ )++toIP6Addr :: (Word64, Word64) -> IPv6Addr+toIP6Addr (h, l) =+ ( fromIntegral $ (h `shiftR` 32) .&. m+ , fromIntegral $ h .&. m+ , fromIntegral $ (l `shiftR` 32) .&. m+ , fromIntegral $ l .&. m+ ) 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+ m = 0xffffffff
Data/IP/Op.hs view
@@ -7,80 +7,108 @@ ---------------------------------------------------------------- -{-|-->>> toIPv4 [127,0,2,1] `masked` intToMask 7-126.0.0.0--}+-- |+--+-- >>> toIPv4 [127,0,2,1] `masked` intToMask 7+-- 126.0.0.0 class Eq a => Addr a where- {-|- The 'masked' function takes an 'Addr' and a contiguous- mask and returned a masked 'Addr'.- -}+ -- |+ -- The 'masked' function takes an 'Addr' and a contiguous+ -- mask and returned a masked 'Addr'. masked :: a -> a -> a- {-|- The 'intToMask' function takes 'Int' and returns a contiguous- mask.- -}++ -- |+ --+ -- The 'intToMask' function takes an 'Int' representing the number of bits to+ -- be set in the returned contiguous mask. When this integer is positive the+ -- bits will be starting from the MSB and from the LSB otherwise.+ --+ -- >>> intToMask 16 :: IPv4+ -- 255.255.0.0+ --+ -- >>> intToMask (-16) :: IPv4+ -- 0.0.255.255+ --+ -- >>> intToMask 16 :: IPv6+ -- ffff::+ --+ -- >>> intToMask (-16) :: IPv6+ -- ::ffff intToMask :: Int -> a instance Addr IPv4 where- masked = maskedIPv4+ masked = maskedIPv4 intToMask = maskIPv4 instance Addr IPv6 where- IP6 (a1,a2,a3,a4) `masked` IP6 (m1,m2,m3,m4) =- IP6 (a1.&.m1,a2.&.m2,a3.&.m3,a4.&.m4)+ masked = maskedIPv6 intToMask = maskIPv6 ---------------------------------------------------------------- -{-|- The >:> operator takes two 'AddrRange'. It returns 'True' if- the first 'AddrRange' contains the second 'AddrRange'. Otherwise,- it returns 'False'.-->>> makeAddrRange ("127.0.2.1" :: IPv4) 8 >:> makeAddrRange "127.0.2.1" 24-True->>> makeAddrRange ("127.0.2.1" :: IPv4) 24 >:> makeAddrRange "127.0.2.1" 8-False->>> makeAddrRange ("2001:DB8::1" :: IPv6) 16 >:> makeAddrRange "2001:DB8::1" 32-True->>> makeAddrRange ("2001:DB8::1" :: IPv6) 32 >:> makeAddrRange "2001:DB8::1" 16-False--}+-- |+-- The >:> operator takes two 'AddrRange'. It returns 'True' if+-- the first 'AddrRange' contains the second 'AddrRange'. Otherwise,+-- it returns 'False'.+--+-- >>> makeAddrRange ("127.0.2.1" :: IPv4) 8 >:> makeAddrRange "127.0.2.1" 24+-- True+-- >>> makeAddrRange ("127.0.2.1" :: IPv4) 24 >:> makeAddrRange "127.0.2.1" 8+-- False+-- >>> makeAddrRange ("2001:DB8::1" :: IPv6) 16 >:> makeAddrRange "2001:DB8::1" 32+-- True+-- >>> makeAddrRange ("2001:DB8::1" :: IPv6) 32 >:> makeAddrRange "2001:DB8::1" 16+-- False (>:>) :: Addr a => AddrRange a -> AddrRange a -> Bool a >:> b = mlen a <= mlen b && (addr b `masked` mask a) == addr a -{-|- The 'toMatchedTo' function take an 'Addr' address and an 'AddrRange',- and returns 'True' if the range contains the address.-->>> ("127.0.2.0" :: IPv4) `isMatchedTo` makeAddrRange "127.0.2.1" 24-True->>> ("127.0.2.0" :: IPv4) `isMatchedTo` makeAddrRange "127.0.2.1" 32-False->>> ("2001:DB8::1" :: IPv6) `isMatchedTo` makeAddrRange "2001:DB8::1" 32-True->>> ("2001:DB8::" :: IPv6) `isMatchedTo` makeAddrRange "2001:DB8::1" 128-False--}-+-- |+-- The 'isMatchedTo' function take an 'Addr' address and an 'AddrRange',+-- and returns 'True' if the range contains the address.+--+-- >>> ("127.0.2.0" :: IPv4) `isMatchedTo` makeAddrRange "127.0.2.1" 24+-- True+-- >>> ("127.0.2.0" :: IPv4) `isMatchedTo` makeAddrRange "127.0.2.1" 32+-- False+-- >>> ("2001:DB8::1" :: IPv6) `isMatchedTo` makeAddrRange "2001:DB8::1" 32+-- True+-- >>> ("2001:DB8::" :: IPv6) `isMatchedTo` makeAddrRange "2001:DB8::1" 128+-- False isMatchedTo :: Addr a => a -> AddrRange a -> Bool isMatchedTo a r = a `masked` mask r == addr r -{-|- The 'makeAddrRange' functions takes an 'Addr' address and a mask- length. It creates a bit mask from the mask length and masks- the 'Addr' address, then returns 'AddrRange' made of them.-->>> makeAddrRange (toIPv4 [127,0,2,1]) 8-127.0.0.0/8->>> makeAddrRange (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) 8-2000:00:00:00:00:00:00:00/8--}+-- |+-- The 'makeAddrRange' functions takes an 'Addr' address and a mask+-- length. It creates a bit mask from the mask length and masks+-- the 'Addr' address, then returns 'AddrRange' made of them.+--+-- >>> makeAddrRange (toIPv4 [127,0,2,1]) 8+-- 127.0.0.0/8+-- >>> makeAddrRange (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) 8+-- 2000::/8 makeAddrRange :: Addr a => a -> Int -> AddrRange a makeAddrRange ad len = AddrRange adr msk len where msk = intToMask len adr = ad `masked` msk++-- | Convert IPv4 range to IPV4-embedded-in-IPV6 range+ipv4RangeToIPv6 :: AddrRange IPv4 -> AddrRange IPv6+ipv4RangeToIPv6 range =+ makeAddrRange+ (toIPv6 [0, 0, 0, 0, 0, 0xffff, (i1 `shift` 8) .|. i2, (i3 `shift` 8) .|. i4])+ (masklen + 96)+ where+ (ip, masklen) = addrRangePair range+ [i1, i2, i3, i4] = fromIPv4 ip++-- |+-- The 'unmakeAddrRange' functions take a 'AddrRange' and+-- returns the network address and a mask length.+--+-- >>> addrRangePair ("127.0.0.0/8" :: AddrRange IPv4)+-- (127.0.0.0,8)+-- >>> addrRangePair ("2000::/8" :: AddrRange IPv6)+-- (2000::,8)+addrRangePair :: Addr a => AddrRange a -> (a, Int)+addrRangePair (AddrRange adr _ len) = (adr, len)
Data/IP/Range.hs view
@@ -1,57 +1,63 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+ module Data.IP.Range where -import Control.Monad import Data.Bits+import Data.Char+import Data.Data (Data) import Data.IP.Addr import Data.IP.Mask import Data.String+import Data.Typeable (Typeable)+import GHC.Generics import Text.Appar.String ---------------------------------------------------------------- -{-|- 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.-->>> (read "192.0.2.1/24" :: IPRange) == IPv4Range (read "192.0.2.0/24" :: AddrRange IPv4)-True->>> (read "2001:db8:00:00:00:00:00:01/48" :: IPRange) == IPv6Range (read "2001:db8:00:00:00:00:00:01/48" :: AddrRange IPv6)-True--}--data IPRange = IPv4Range { ipv4range :: AddrRange IPv4 }- | IPv6Range { ipv6range :: AddrRange IPv6 }- deriving (Eq)+-- |+-- 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.+--+-- >>> (read "192.0.2.1/24" :: IPRange) == IPv4Range (read "192.0.2.0/24" :: AddrRange IPv4)+-- True+-- >>> (read "2001:db8:00:00:00:00:00:01/48" :: IPRange) == IPv6Range (read "2001:db8:00:00:00:00:00:01/48" :: AddrRange IPv6)+-- True+data IPRange+ = IPv4Range {ipv4range :: AddrRange IPv4}+ | IPv6Range {ipv6range :: AddrRange IPv6}+ deriving (Eq, Ord, Data, Generic, Typeable) ---------------------------------------------------------------- -- -- Range -- -{-|- The Addr range consists of an address, a contiguous mask,- and mask length. The contiguous mask and the mask length- are essentially same information but contained for pre- 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.-->>> read "192.0.2.1/24" :: AddrRange IPv4-192.0.2.0/24->>> read "2001:db8:00:00:00:00:00:01/48" :: AddrRange IPv6-2001:db8:00:00:00:00:00:00/48--}-data AddrRange a = AddrRange {- -- |The 'addr' function returns an address from 'AddrRange'.- addr :: !a- -- |The 'mask' function returns a contiguous 'IP' mask from 'AddrRange'.- , mask :: !a- -- |The 'mlen' function returns a mask length from 'AddrRange'.- , mlen :: {-# UNPACK #-} !Int- } deriving (Eq, Ord)+-- |+-- The Addr range consists of an address, a contiguous mask,+-- and mask length. The contiguous mask and the mask length+-- are essentially same information but contained for pre+-- 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.+--+-- >>> read "192.0.2.1/24" :: AddrRange IPv4+-- 192.0.2.0/24+-- >>> read "2001:db8:00:00:00:00:00:01/48" :: AddrRange IPv6+-- 2001:db8::/48+data AddrRange a = AddrRange+ { addr :: !a+ -- ^ The 'addr' function returns an address from 'AddrRange'.+ , mask :: !a+ -- ^ The 'mask' function returns a contiguous 'IP' mask from 'AddrRange'.+ , mlen :: {-# UNPACK #-} !Int+ -- ^ The 'mlen' function returns a mask length from 'AddrRange'.+ }+ deriving (Eq, Ord, Data, Generic, Typeable) ---------------------------------------------------------------- --@@ -73,12 +79,12 @@ instance Read IPRange where readsPrec _ = parseIPRange -parseIPRange :: String -> [(IPRange,String)]+parseIPRange :: String -> [(IPRange, String)] parseIPRange cs = case runParser ip4range cs of- (Just ip,rest) -> [(IPv4Range ip,rest)]- (Nothing,_) -> case runParser ip6range cs of- (Just ip,rest) -> [(IPv6Range ip,rest)]- (Nothing,_) -> []+ (Just ip, rest) -> [(IPv4Range ip, rest)]+ (Nothing, _) -> case runParser ip6range cs of+ (Just ip, rest) -> [(IPv6Range ip, rest)]+ (Nothing, _) -> [] instance Read (AddrRange IPv4) where readsPrec _ = parseIPv4Range@@ -86,43 +92,52 @@ instance Read (AddrRange IPv6) where readsPrec _ = parseIPv6Range -parseIPv4Range :: String -> [(AddrRange IPv4,String)]+parseIPv4Range :: String -> [(AddrRange IPv4, String)] parseIPv4Range cs = case runParser ip4range cs of- (Nothing,_) -> []- (Just a4,rest) -> [(a4,rest)]+ (Nothing, _) -> []+ (Just a4, rest) -> [(a4, rest)] -parseIPv6Range :: String -> [(AddrRange IPv6,String)]+parseIPv6Range :: String -> [(AddrRange IPv6, String)] parseIPv6Range cs = case runParser ip6range cs of- (Nothing,_) -> []- (Just a6,rest) -> [(a6,rest)]+ (Nothing, _) -> []+ (Just a6, rest) -> [(a6, rest)] +maskLen :: Int -> Parser Int+maskLen maxLen = do+ hasSlash <- option False $ True <$ char '/'+ if hasSlash+ then+ 0 <$ char '0'+ <|> (toInt =<< (:) <$> oneOf ['1' .. '9'] <*> many digit)+ else return maxLen+ where+ toInt ds = maybe (fail "mask length") pure $ foldr go Just ds 0+ go !d !f !n =+ let n' = n * 10 + ord d - 48+ in if n' <= maxLen then f n' else Nothing+ ip4range :: Parser (AddrRange IPv4) ip4range = do- ip <- ip4- len <- option 32 $ char '/' >> dig- check len+ skipSpaces+ ip <- toIPv4 <$> ip4' False+ len <- maskLen 32 let msk = maskIPv4 len adr = ip `maskedIPv4` msk return $ AddrRange adr msk len- where- check len = when (len < 0 || 32 < len) (fail "IPv4 mask length") maskedIPv4 :: IPv4 -> IPv4 -> IPv4 IP4 a `maskedIPv4` IP4 m = IP4 (a .&. m) ip6range :: Parser (AddrRange IPv6) ip6range = do- ip <- ip6- len <- option 128 $ char '/' >> dig- check len+ ip <- ip6' False+ len <- maskLen 128 let msk = maskIPv6 len adr = ip `maskedIPv6` msk return $ AddrRange adr msk len- where- check len = when (len < 0 || 128 < len) (fail ("IPv6 mask length: " ++ show len)) maskedIPv6 :: IPv6 -> IPv6 -> IPv6-IP6 (a1,a2,a3,a4) `maskedIPv6` IP6 (m1,m2,m3,m4) = IP6 (a1.&.m1,a2.&.m2,a3.&.m3,a4.&.m4)+IP6 (a1, a2, a3, a4) `maskedIPv6` IP6 (m1, m2, m3, m4) = IP6 (a1 .&. m1, a2 .&. m2, a3 .&. m3, a4 .&. m4) ---------------------------------------------------------------- --
Data/IP/RouteTable.hs view
@@ -1,24 +1,33 @@-{-|- 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.-- For more information, see:- <http://www.mew.org/~kazu/proj/iproute/>--}+-- |+-- 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.+--+-- For more information, see:+-- <http://www.mew.org/~kazu/proj/iproute/> module Data.IP.RouteTable (- -- * Documentation- -- ** Routable class- Routable (..)- -- ** Type for IP routing table- , IPRTable- -- ** Functions to manipulate an IP routing table- , empty, insert, delete- , I.lookup- , findMatch- , fromList, toList- ) where+ -- * Documentation++ -- ** Routable class+ Routable (..),++ -- ** Type for IP routing table+ IPRTable,++ -- ** Functions to manipulate an IP routing table+ empty,+ insert,+ delete,+ I.lookup,+ I.lookupKeyValue,+ I.lookupAll,+ findMatch,+ fromList,+ toList,+ foldlWithKey,+ foldrWithKey,+) where import Data.IP.RouteTable.Internal as I
Data/IP/RouteTable/Internal.hs view
@@ -1,39 +1,48 @@-{-|- IP routing table is a tree of 'AddrRange'- 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.--}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- IP routing table is a tree of 'AddrRange'+-- 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 Control.Applicative hiding (empty)+import qualified Control.Applicative as A (empty) import Control.Monad import Data.Bits+import Data.Foldable (Foldable (..)) import Data.IP.Addr import Data.IP.Op import Data.IP.Range import Data.IntMap (IntMap, (!)) import qualified Data.IntMap as IM (fromList)-import Data.List (foldl')+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Data.Traversable import Data.Word+import GHC.Generics (Generic, Generic1) import Prelude hiding (lookup) +-- $setup+-- >>> :set -XOverloadedStrings+ ---------------------------------------------------------------- -{-|- A class to contain IPv4 and IPv6.--}+-- |+-- A class to contain IPv4 and IPv6. class Addr a => Routable a where- {-|- The 'intToTBit' function takes 'Int' and returns an 'Routable' address- whose only n-th bit is set.- -}- intToTBit :: Int -> a- {-|- The 'isZero' function takes an 'Routable' address and an test bit- 'Routable' address and returns 'True' is the bit is unset,- otherwise returns 'False'.- -}+ -- |+ -- The 'intToTBit' function takes 'Int' and returns an 'Routable' address+ -- whose only n-th bit is set.+ intToTBit :: Int -> a++ -- |+ -- The 'isZero' function takes an 'Routable' address and an test bit+ -- 'Routable' address and returns 'True' is the bit is unset,+ -- otherwise returns 'False'. isZero :: a -> a -> Bool instance Routable IPv4 where@@ -42,7 +51,7 @@ instance Routable IPv6 where intToTBit = intToTBitIPv6- isZero a b = a `masked` b == IP6 (0,0,0,0)+ isZero a b = a `masked` b == IP6 (0, 0, 0, 0) ---------------------------------------------------------------- --@@ -59,84 +68,111 @@ intToTBitsWord32 = iterate (`shift` (-1)) 0x80000000 intToTBitsIPv4 :: IntMap IPv4Addr-intToTBitsIPv4 = IM.fromList $ zip [0..32] intToTBitsWord32+intToTBitsIPv4 = IM.fromList $ zip [0 .. 32] intToTBitsWord32 intToTBitsIPv6 :: IntMap IPv6Addr-intToTBitsIPv6 = IM.fromList $ zip [0..128] bs+intToTBitsIPv6 = IM.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)]+ 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 ---------------------------------------------------------------- -{-|- The Tree structure for IP routing table based on TRIE with- one way branching removed. This is an abstract data type,- so you cannot touch its inside. Please use 'insert' or 'lookup', instead.--}-data IPRTable k a =- Nil- | Node !(AddrRange k) !k !(Maybe a) !(IPRTable k a) !(IPRTable k a)- deriving (Eq, Show)+-- |+-- The Tree structure for IP routing table based on TRIE with+-- one way branching removed. This is an abstract data type,+-- so you cannot touch its inside. Please use 'insert' or 'lookup', instead.+data IPRTable k a+ = Nil+ | Node !(AddrRange k) !k !(Maybe a) !(IPRTable k a) !(IPRTable k a)+ deriving (Eq, Generic, Generic1, Show) ---------------------------------------------------------------- -{-|- The 'empty' function returns an empty IP routing table.-->>> (empty :: IPRTable IPv4 ()) == fromList []-True--}+-- |+-- The 'empty' function returns an empty IP routing table.+--+-- >>> (empty :: IPRTable IPv4 ()) == fromList []+-- True empty :: Routable k => IPRTable k a empty = Nil -----------------------------------------------------------------+instance Functor (IPRTable k) where+ fmap _ Nil = Nil+ fmap f (Node r a mv b1 b2) = Node r a (f <$> mv) (fmap f b1) (fmap f b2) -{-|- The 'insert' function inserts a value with a key of 'AddrRange' to 'IPRTable'- and returns a new 'IPRTable'.+instance Foldable (IPRTable k) where+ foldMap _ Nil = mempty+ foldMap f (Node _ _ mv b1 b2) = foldMap f mv `mappend` foldMap f b1 `mappend` foldMap f b2 ->>> (insert ("127.0.0.1" :: AddrRange IPv4) () empty) == fromList [("127.0.0.1",())]-True--}-insert :: (Routable k) => AddrRange k -> a -> IPRTable k a -> IPRTable k a+instance Traversable (IPRTable k) where+ traverse _ Nil = pure Nil+ traverse f (Node r a mv b1 b2) = Node r a <$> traverse f mv <*> traverse f b1 <*> traverse f b2++-- | Note that Semigroup and Monoid instances are right-biased.+-- That is, if both arguments have the same key, the value from the right+-- argument will be used.+-- Since: 1.7.5+instance Routable k => Semigroup (IPRTable k a) where+ a <> b = foldlWithKey (\rt k v -> insert k v rt) a b+ stimes = stimesIdempotent++-- | Since: 1.7.5+instance Routable k => Monoid (IPRTable k a) where+ mempty = empty+ mappend = (<>)++----------------------------------------------------------------++-- |+-- The 'insert' function inserts a value with a key of 'AddrRange' to 'IPRTable'+-- and returns a new 'IPRTable'.+--+-- >>> (insert ("127.0.0.1" :: AddrRange IPv4) () empty) == fromList [("127.0.0.1",())]+-- True+insert :: Routable k => AddrRange k -> a -> IPRTable k a -> IPRTable k a insert k1 v1 Nil = Node k1 tb1 (Just v1) Nil Nil where tb1 = keyToTestBit k1 insert k1 v1 s@(Node k2 tb2 v2 l r)- | k1 == k2 = Node k1 tb1 (Just v1) l r- | k2 >:> k1 = if isLeft k1 tb2 then- Node k2 tb2 v2 (insert k1 v1 l) r- else- Node k2 tb2 v2 l (insert k1 v1 r)- | k1 >:> k2 = if isLeft k2 tb1 then- Node k1 tb1 (Just v1) s Nil- else- Node k1 tb1 (Just v1) Nil s- | otherwise = let n = Node k1 tb1 (Just v1) Nil Nil- in link n s+ | k1 == k2 = Node k1 tb1 (Just v1) l r+ | k2 >:> k1 =+ if isLeft k1 tb2+ then+ Node k2 tb2 v2 (insert k1 v1 l) r+ else+ Node k2 tb2 v2 l (insert k1 v1 r)+ | k1 >:> k2 =+ if isLeft k2 tb1+ then+ Node k1 tb1 (Just v1) s Nil+ else+ Node k1 tb1 (Just v1) Nil s+ | otherwise =+ let n = Node k1 tb1 (Just v1) Nil Nil+ in link n s where tb1 = keyToTestBit k1 link :: Routable k => IPRTable k a -> IPRTable k a -> IPRTable k a link s1@(Node k1 _ _ _ _) s2@(Node k2 _ _ _ _)- | isLeft k1 tbg = Node kg tbg Nothing s1 s2- | otherwise = Node kg tbg Nothing s2 s1+ | isLeft k1 tbg = Node kg tbg Nothing s1 s2+ | otherwise = Node kg tbg Nothing s2 s1 where kg = glue 0 k1 k2 tbg = keyToTestBit kg link _ _ = error "link" -glue :: (Routable k) => Int -> AddrRange k -> AddrRange k -> AddrRange k+glue :: Routable k => Int -> AddrRange k -> AddrRange k -> AddrRange k glue n k1 k2- | addr k1 `masked` mk == addr k2 `masked` mk = glue (n + 1) k1 k2- | otherwise = makeAddrRange (addr k1) (n - 1)+ | addr k1 `masked` mk == addr k2 `masked` mk = glue (n + 1) k1 k2+ | otherwise = makeAddrRange (addr k1) (n - 1) where mk = intToMask n @@ -148,116 +184,192 @@ ---------------------------------------------------------------- -{-|- The 'delete' function deletes a value by a key of 'AddrRange' from 'IPRTable'- and returns a new 'IPRTable'.-->>> delete "127.0.0.1" (insert "127.0.0.1" () empty) == (empty :: IPRTable IPv4 ())-True--}-delete :: (Routable k) => AddrRange k -> IPRTable k a -> IPRTable k a+-- |+-- The 'delete' function deletes a value by a key of 'AddrRange' from 'IPRTable'+-- and returns a new 'IPRTable'.+--+-- >>> delete "127.0.0.1" (insert "127.0.0.1" () empty) == (empty :: IPRTable IPv4 ())+-- True+delete :: Routable k => AddrRange k -> IPRTable k a -> IPRTable k a delete _ Nil = Nil delete k1 s@(Node k2 tb2 v2 l r)- | k1 == k2 = node k2 tb2 Nothing l r- | k2 >:> k1 = if isLeft k1 tb2 then- node k2 tb2 v2 (delete k1 l) r- else- node k2 tb2 v2 l (delete k1 r)- | otherwise = s+ | k1 == k2 = node k2 tb2 Nothing l r+ | k2 >:> k1 =+ if isLeft k1 tb2+ then+ node k2 tb2 v2 (delete k1 l) r+ 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+node k tb v l r = Node k tb v l r ---------------------------------------------------------------- -{-|- The 'lookup' function looks up 'IPRTable' with a key of 'AddrRange'.- If a routing information in 'IPRTable' matches the key, its value- is returned.-->>> let v4 = ["133.4.0.0/16","133.5.0.0/16","133.5.16.0/24","133.5.23.0/24"] :: [AddrRange IPv4]->>> let rt = fromList $ zip v4 v4->>> 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--}+-- |+-- The 'lookup' function looks up 'IPRTable' with a key of 'AddrRange'.+-- If a routing information in 'IPRTable' matches the key, its value+-- is returned.+--+-- >>> let v4 = ["133.4.0.0/16","133.5.0.0/16","133.5.16.0/24","133.5.23.0/24"] :: [AddrRange IPv4]+-- >>> let rt = fromList $ zip v4 v4+-- >>> 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 lookup :: Routable k => AddrRange k -> IPRTable k a -> Maybe a-lookup k s = search k s Nothing+lookup k s = fmap snd (search k s Nothing) -search :: Routable k => AddrRange k -> IPRTable k a -> Maybe a -> Maybe a+-- |+-- The 'lookupKeyValue' function looks up 'IPRTable' with a key of 'AddrRange'.+-- If a routing information in 'IPRTable' matches the key, both key and value+-- are returned.+--+-- >>> :set -XOverloadedStrings+-- >>> let rt = fromList ([("192.168.0.0/24", 1), ("10.10.0.0/16", 2)] :: [(AddrRange IPv4, Int)])+-- >>> lookupKeyValue "127.0.0.1" rt+-- Nothing+-- >>> lookupKeyValue "192.168.0.1" rt+-- Just (192.168.0.0/24,1)+-- >>> lookupKeyValue "10.10.0.1" rt+-- Just (10.10.0.0/16,2)+lookupKeyValue+ :: Routable k => AddrRange k -> IPRTable k a -> Maybe (AddrRange k, a)+lookupKeyValue k s = search k s Nothing++search+ :: Routable k+ => AddrRange k+ -> IPRTable k a+ -> Maybe (AddrRange k, a)+ -> Maybe (AddrRange k, a) search _ Nil res = res search k1 (Node k2 tb2 Nothing l r) res- | k1 == k2 = res- | k2 >:> k1 = if isLeft k1 tb2 then- search k1 l res- else- search k1 r res- | otherwise = res-search k1 (Node k2 tb2 vl l r) res- | k1 == k2 = vl- | k2 >:> k1 = if isLeft k1 tb2 then- search k1 l vl- else- search k1 r vl- | otherwise = res------------------------------------------------------------------+ | k1 == k2 = res+ | k2 >:> k1 =+ if isLeft k1 tb2+ then+ search k1 l res+ else+ search k1 r res+ | otherwise = res+search k1 (Node k2 tb2 (Just vl) l r) res+ | k1 == k2 = Just (k1, vl)+ | k2 >:> k1 =+ if isLeft k1 tb2+ then+ search k1 l $ Just (k2, vl)+ else+ search k1 r $ Just (k2, 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.+-- |+-- 'lookupAll' is a version of 'lookup' that returns all entries matching the+-- given key, not just the longest match.+--+-- >>> :set -XOverloadedStrings+-- >>> let rt = fromList ([("192.168.0.0/24", 1), ("10.10.0.0/16", 2), ("10.0.0.0/8", 3)] :: [(AddrRange IPv4, Int)])+-- >>> lookupAll "127.0.0.1" rt+-- []+-- >>> lookupAll "192.168.0.1" rt+-- [(192.168.0.0/24,1)]+-- >>> lookupAll "10.10.0.1" rt+-- [(10.10.0.0/16,2),(10.0.0.0/8,3)]+lookupAll :: Routable k => AddrRange k -> IPRTable k a -> [(AddrRange k, a)]+lookupAll range = go []+ where+ go acc Nil = acc+ go acc (Node k tb Nothing l r)+ | k == range = acc+ | k >:> range = go acc $ if isLeft range tb then l else r+ | otherwise = acc+ go acc (Node k tb (Just v) l r)+ | k == range = (k, v) : acc+ | k >:> range = go ((k, v) : acc) $ if isLeft range tb then l else r+ | otherwise = acc ->>> let v4 = ["133.4.0.0/16","133.5.0.0/16","133.5.16.0/24","133.5.23.0/24"] :: [AddrRange IPv4]->>> let rt = fromList $ zip v4 $ repeat ()->>> findMatch "133.4.0.0/15" rt :: [(AddrRange IPv4,())]-[(133.4.0.0/16,()),(133.5.0.0/16,()),(133.5.16.0/24,()),(133.5.23.0/24,())]--}+---------------------------------------------------------------- -findMatch :: MonadPlus m => Routable k => AddrRange k -> IPRTable k a -> m (AddrRange k, a)-findMatch _ Nil = mzero+-- |+-- The 'findMatch' function looks up 'IPRTable' with a key of 'AddrRange'.+-- If the key matches routing informations in 'IPRTable', they are+-- returned.+--+-- >>> let v4 = ["133.4.0.0/16","133.5.0.0/16","133.5.16.0/24","133.5.23.0/24"] :: [AddrRange IPv4]+-- >>> let rt = fromList $ zip v4 $ repeat ()+-- >>> findMatch "133.4.0.0/15" rt :: [(AddrRange IPv4,())]+-- [(133.4.0.0/16,()),(133.5.0.0/16,()),(133.5.16.0/24,()),(133.5.23.0/24,())]+findMatch+ :: Alternative m => Routable k => AddrRange k -> IPRTable k a -> m (AddrRange k, a)+findMatch _ Nil = A.empty 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+ | k1 >:> k2 = findMatch k1 l <|> findMatch k1 r+ | k2 >:> k1 = findMatch k1 l <|> findMatch k1 r+ | otherwise = A.empty 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+ | k1 >:> k2 = pure (k2, vl) <|> findMatch k1 l <|> findMatch k1 r+ | k2 >:> k1 = findMatch k1 l <|> findMatch k1 r+ | otherwise = A.empty ---------------------------------------------------------------- -{-|- The 'fromList' function creates a new IP routing table from- a list of a pair of 'IPrange' and value.--}+-- |+-- The 'fromList' function creates a new IP routing table from+-- a list of a pair of 'IPrange' and value. fromList :: Routable k => [(AddrRange k, a)] -> IPRTable k a-fromList = foldl' (\s (k,v) -> insert k v s) empty+fromList = foldl' (\s (k, v) -> insert k v s) empty -{-|- The 'toList' function creates a list of a pair of 'AddrRange' and- value from an IP routing table.--}+-- |+-- The 'toList' function creates a list of a pair of 'AddrRange' and+-- value from an IP routing table. toList :: Routable k => IPRTable k a -> [(AddrRange k, a)] toList = foldt toL [] where toL Nil xs = xs- toL (Node _ _ Nothing _ _) xs = xs- toL (Node k _ (Just a) _ _) xs = (k,a) : xs+ toL (Node _ _ Nothing _ _) xs = xs+ toL (Node 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++-- | /O(n)/. Fold the keys and values in the IPRTable using the given+-- left-associative binary operator.+-- This function is equivalent to Data.Map.foldlWithKey with necessary to+-- IPRTable changes.+-- Since: 1.7.5+foldlWithKey :: (b -> AddrRange k -> a -> b) -> b -> IPRTable k a -> b+foldlWithKey f zr = go zr+ where+ go z Nil = z+ go z (Node _ _ Nothing l r) = go (go z l) r+ go z (Node n _ (Just v) l r) = go (f (go z l) n v) r+{-# INLINE foldlWithKey #-}++-- | /O(n)/. Fold the keys and values in the IPRTable using the given+-- right-associative binary operator.+-- This function is equivalent to Data.Map.foldrWithKey with necessary to+-- IPRTable changes.+-- Since: 1.7.5+foldrWithKey :: (AddrRange k -> a -> b -> b) -> b -> IPRTable k a -> b+foldrWithKey f zr = go zr+ where+ go z Nil = z+ go z (Node _ _ Nothing l r) = go (go z r) l+ go z (Node n _ (Just v) l r) = go (f n v (go z r)) l+{-# INLINE foldrWithKey #-}
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
iproute.cabal view
@@ -1,62 +1,83 @@-Name: iproute-Version: 1.2.12-Author: Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-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, Network-Cabal-Version: >= 1.10-Build-Type: Simple+cabal-version: >=1.10+name: iproute+version: 1.7.15+license: BSD3+license-file: LICENSE+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Kazu Yamamoto <kazu@iij.ad.jp>+tested-with:+ ghc ==7.8.4 ghc ==7.10.3 ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.4+ ghc ==8.6.5 ghc ==8.8.2 -Library- Default-Language: Haskell2010- GHC-Options: -Wall- Exposed-Modules: Data.IP- Data.IP.RouteTable- Other-Modules: Data.IP.Addr- Data.IP.Mask- Data.IP.Op- Data.IP.Range- Data.IP.RouteTable.Internal- Build-Depends: base >= 4 && < 5- , appar- , byteorder- , containers- , network+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. -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+category: Algorithms, Network+build-type: Simple -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- , IPSpec- Build-Depends: base- , hspec- , QuickCheck- , appar- , byteorder- , containers- , network- , safe+source-repository head+ type: git+ location: git://github.com/kazu-yamamoto/iproute.git -Source-Repository head- Type: git- Location: git://github.com/kazu-yamamoto/iproute.git+library+ exposed-modules:+ Data.IP+ Data.IP.Builder+ Data.IP.Internal+ Data.IP.RouteTable+ Data.IP.RouteTable.Internal++ other-modules:+ Data.IP.Addr+ Data.IP.Mask+ Data.IP.Op+ Data.IP.Range++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ appar,+ byteorder,+ bytestring,+ containers,+ network++ if impl(ghc <8.0)+ build-depends: semigroups >=0.17++ if impl(ghc >=8)+ default-extensions: Strict StrictData++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test+ other-modules:+ RouteTableSpec+ BuilderSpec+ IPSpec++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.6 && <5,+ hspec,+ QuickCheck,+ appar,+ byteorder,+ bytestring,+ containers,+ network,+ safe,+ iproute++ if impl(ghc <8.0)+ build-depends: semigroups >=0.17
+ test/BuilderSpec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module BuilderSpec where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Control.Monad+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy.Char8 as LBSC+import Data.IP+import Data.IP.Builder+import Data.IP.RouteTable+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++----------------------------------------------------------------+--+-- Arbitrary+--++b16, b17 :: Int+b16 = 65535+b17 = (b16 + 1) * 2 - 1++instance Arbitrary IPv4 where+ arbitrary = arbitraryAdr toIPv4 255 255 4++-- | Bias the IPv6 generator to produce 0s with ~50% probability, so that we+-- stand a non-trivial chance of testing the gap computation corner cases.+-- We also give 0xffff enhanced odds, by choosing that instead of 0 one+-- time out of 16.+instance Arbitrary IPv6 where+ arbitrary = arbitraryAdr toIPv6 b16 b17 8++arbitraryAdr :: Routable a => ([Int] -> a) -> Int -> Int -> Int -> Gen a+arbitraryAdr func width range adrlen =+ func <$> replicateM adrlen biased+ where+ biased = do+ n <- choose (0, range)+ if n <= width+ then return n+ else do+ f <- choose (0, 15 :: Int)+ if f < 15+ then return 0+ else return width++----------------------------------------------------------------+--+-- Spec+--++spec :: Spec+spec = do+ describe "test builders" $ do+ prop "IPv4 Builder matches Show instance" v4_compat+ prop "IPv6 Builder matches Show instance" v6_compat++v4_compat :: IPv4 -> Bool+v4_compat a = builderToString (ipv4Builder a) == show a++v6_compat :: IPv6 -> Bool+v6_compat a = builderToString (ipv6Builder a) == show a++builderToString :: BB.Builder -> String+builderToString = LBSC.unpack . BB.toLazyByteString
test/IPSpec.hs view
@@ -1,10 +1,14 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module IPSpec where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative+#endif import Data.IP+import Data.Maybe (isJust) import Safe (readMay) import Test.Hspec import Test.Hspec.QuickCheck (prop)@@ -20,8 +24,23 @@ data InvalidIPv4Str = Iv4 String deriving (Show) instance Arbitrary InvalidIPv4Str where- arbitrary = arbitraryIIPv4Str arbitrary 32+ arbitrary =+ frequency+ [ (8, arbitraryIIPv4Str arbitrary 32)+ , -- an IPv4 address should not end with a trailing `.`+ (1, Iv4 . (++ ".") . show <$> genIPv4)+ , -- an IPv4 address with mask should not include a white space + ( 1+ , (\ip (NonNegative len) -> Iv4 (show ip ++ " /" ++ show (len :: Integer)))+ <$> genIPv4+ <*> arbitrary+ )+ ]+ where+ genIPv4 :: Gen IPv4+ genIPv4 = arbitrary+ arbitraryIIPv4Str :: Gen IPv4 -> Int -> Gen InvalidIPv4Str arbitraryIIPv4Str adrGen msklen = toIv4 <$> adrGen <*> lenGen where@@ -53,8 +72,16 @@ prop "IPv6 failure" ipv6_fail it "can read even if unnecessary spaces exist" $ do (readMay " 127.0.0.1" :: Maybe IPv4) `shouldBe` readMay "127.0.0.1"+ it "does not read overflow IPv4 octets" $ do+ (readMay "127.0.0.18446744073709551617" :: Maybe IPv4) `shouldBe` Nothing it "can read even if unnecessary spaces exist" $ do (readMay " ::1" :: Maybe IPv4) `shouldBe` readMay "::1"+ it "does not read overflow mask lengths" $ do+ (readMay "192.168.0.1/18446744073709551648" :: Maybe (AddrRange IPv4))+ `shouldBe` Nothing+ it "can read embedded v4 in v6 range" $ do+ (readMay "::ffff:192.0.2.0/120" :: Maybe (AddrRange IPv6))+ `shouldSatisfy` isJust to_str_ipv4 :: AddrRange IPv4 -> Bool to_str_ipv4 a = readMay (show a) == Just a
test/RouteTableSpec.hs view
@@ -1,13 +1,20 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module RouteTableSpec where -import Control.Applicative+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative hiding (empty)+#endif import Control.Monad+import qualified Data.Foldable as Foldable+import Data.Function (on) import Data.IP import Data.IP.RouteTable.Internal-import Data.List (sort, nub)+import Data.List (nub, sort)+import qualified Data.List as List+import Data.Monoid ((<>)) import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck@@ -33,7 +40,7 @@ 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)+arbitraryIP adrGen msklen = makeAddrRange <$> adrGen <*> choose (0, msklen) ---------------------------------------------------------------- --@@ -43,19 +50,30 @@ spec :: Spec spec = do describe "fromList" $ do- prop "creates the same tree for random input and ordered input"+ 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"+ prop+ "creates the same tree for random input and ordered input" (sort_ip :: [AddrRange IPv6] -> Bool)- prop "stores input in the incremental order"+ prop+ "stores input in the incremental order" (ord_ip :: [AddrRange IPv4] -> Bool)- prop "stores input in the incremental order"+ prop+ "stores input in the incremental order" (ord_ip :: [AddrRange IPv6] -> Bool) describe "toList" $ do- prop "expands as sorted"+ prop+ "expands as sorted" (fromto_ip :: [AddrRange IPv4] -> Bool)- prop "expands as sorted"+ 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')@@ -65,7 +83,7 @@ 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+ ys = map fst . toList . fromList $ zip xs xs ord_ip :: Routable a => [AddrRange a] -> Bool ord_ip xs = isOrdered . fromList $ zip xs xs@@ -79,3 +97,31 @@ 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 =+ length ys > 0 ==>+ let xs = List.nubBy ((==) `on` fst) ys+ m = fromList xs+ in Foldable.foldl (+) n m == List.foldr (+) n (List.map snd xs)+ && Foldable.foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs))+ && foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs)++prop_foldr :: Int -> [(AddrRange IPv4, Int)] -> Property+prop_foldr n ys =+ length ys > 0 ==>+ let xs = List.nubBy ((==) `on` fst) ys+ m = fromList xs+ in Foldable.foldr (+) n m == List.foldr (+) n (List.map snd xs)+ && Foldable.foldr (:) [] m == List.map snd (List.sortBy (compare `on` fst) xs)+ && foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs)++prop_monoid :: [(AddrRange IPv4, ())] -> [(AddrRange IPv4, ())] -> Property+prop_monoid xs ys =+ length xs > 0 && length ys > 0 ==>+ let xm = fromList xs+ ym = fromList ys+ in empty <> xm == xm+ && ym <> empty == ym+ && xm <> ym == fromList (xs ++ ys)
− test/doctests.hs
@@ -1,6 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest ["-XOverloadedStrings", "Data/IP.hs", "Data/IP/RouteTable.hs"]