iproute 1.7.14 → 1.7.15
raw patch · 14 files changed
+989/−860 lines, 14 filessetup-changed
Files
- Data/IP.hs +42/−27
- Data/IP/Addr.hs +364/−320
- Data/IP/Builder.hs +149/−99
- Data/IP/Internal.hs +7/−6
- Data/IP/Mask.hs +15/−12
- Data/IP/Op.hs +72/−80
- Data/IP/Range.hs +58/−60
- Data/IP/RouteTable.hs +30/−25
- Data/IP/RouteTable/Internal.hs +187/−186
- Setup.hs +1/−0
- iproute.cabal +1/−1
- test/BuilderSpec.hs +7/−8
- test/IPSpec.hs +19/−8
- test/RouteTableSpec.hs +37/−28
Data/IP.hs view
@@ -1,31 +1,46 @@-{-|- Data structures to express IPv4, IPv6 and IP range.--}+-- |+-- Data structures to express IPv4, IPv6 and IP range. module Data.IP (- -- * 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+ -- * 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,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} module Data.IP.Addr where @@ -12,61 +12,58 @@ 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 GHC.Enum (succError,predError)-import GHC.Generics ---------------------------------------------------------------- -{-|- 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)--{-|- Equality over IP addresses. Correctly compare IPv4 and IPv4-embedded-in-IPv6 addresses.+-- |+-- 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 "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--}+-- |+-- 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-+ (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 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+ (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@@ -76,40 +73,37 @@ -- This is host byte order type IPv4Addr = 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.+type IPv6Addr = (Word32, Word32, Word32, Word32) ->>> read "192.0.2.1" :: IPv4-192.0.2.1--}+-- |+-- 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)--{-|- 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.+ deriving (Eq, Ord, Bounded, Data, Generic, Typeable) ->>> 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--}+-- |+-- 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)-+ deriving (Eq, Ord, Bounded, Data, Generic, Typeable) ---------------------------------------------------------------- --@@ -122,37 +116,41 @@ 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)+ 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)+ 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)+ 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'+ 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'+ 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@@ -191,24 +189,26 @@ 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+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+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 ---------------------------------------------------------------- --@@ -231,79 +231,78 @@ -- /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+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 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..]+ 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 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--}+-- |+-- 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 [a1, a2, a3, a4] = IP4 w where- w = (fromIntegral a1 .&. 0xff) `unsafeShiftL` 24 .|.- (fromIntegral a2 .&. 0xff) `unsafeShiftL` 16 .|.- (fromIntegral a3 .&. 0xff) `unsafeShiftL` 8 .|.- (fromIntegral a4 .&. 0xff)+ 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 '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--}+-- |+-- 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 #-} -{-|- 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--}+-- |+-- 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 [i1,i2,i3,i4,i5,i6,i7,i8] = IP6 (x1,x2,x3,x4)+toIPv6 [i1, i2, i3, i4, i5, i6, i7, i8] = IP6 (x1, x2, x3, x4) where !x1 = fromIntegral $ (i1 .&. 0xffff) `unsafeShiftL` 16 .|. (i2 .&. 0xffff) !x2 = fromIntegral $ (i3 .&. 0xffff) `unsafeShiftL` 16 .|. (i4 .&. 0xffff)@@ -312,49 +311,71 @@ 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--}+-- |+-- 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+ [ 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--}+-- |+-- 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 #-}@@ -364,13 +385,12 @@ -- IPToInt -- -{-|- 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]--}+-- |+-- 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) = split w 0o30 : split w 0o20 : split w 0o10 : split w 0 : [] where@@ -378,64 +398,64 @@ split a n = fromIntegral $ a `unsafeShiftR` n .&. 0xff {-# INLINE fromIPv4 #-} -{-|- 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--}+-- |+-- 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 #-} -{-|- 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]--}+-- |+-- 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)) = split w1 . split w2 . split w3 . split w4 $ [] where split :: Word32 -> [Int] -> [Int]- split n acc = fromIntegral (n `unsafeShiftR` 0x10 .&. 0xffff) :- fromIntegral (n .&. 0xffff) : acc+ 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]--}+-- |+-- 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+ split n acc =+ fromIntegral (n `unsafeShiftR` 24 .&. 0xff)+ : fromIntegral (n `unsafeShiftR` 16 .&. 0xff)+ : fromIntegral (n `unsafeShiftR` 8 .&. 0xff)+ : fromIntegral (n .&. 0xff)+ : acc -@since 1.7.9--}+-- |+-- 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 #-}@@ -454,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)] ---------------------------------------------------------------- --@@ -491,13 +511,14 @@ -- octet :: Parser Int-octet = 0 <$ char '0'- <|> (toInt =<< (:) <$> oneOf ['1'..'9'] <*> many digit)+octet =+ 0 <$ char '0'+ <|> (toInt =<< (:) <$> oneOf ['1' .. '9'] <*> many digit) where 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+ let n' = n * 10 + ord d - 48+ in if n' <= 255 then f n' else Nothing ip4 :: Parser IPv4 ip4 = skipSpaces >> toIPv4 <$> ip4' True@@ -513,7 +534,7 @@ a3 <- octet let as = [a0, a1, a2, a3] when checkTermination $- skipSpaces >> termination+ skipSpaces >> termination return as skipSpaces :: Parser ()@@ -521,8 +542,8 @@ termination :: Parser () termination = P $ \str -> case str of- [] -> (Just (), "")- _ -> (Nothing, str)+ [] -> (Just (), "")+ _ -> (Nothing, str) ---------------------------------------------------------------- --@@ -554,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' True- format [] (bs ++ ip4ToIp6 embedded))- -- matches 2001:db8::192.0.2.1- <|> try (do bs1 <- manyTill (try $ hex <* char ':') (char ':')- bs2 <- option [] beforeEmbedded- embedded <- ip4' True- format bs1 (bs2 ++ ip4ToIp6 embedded))- -- matches 2001:db8:11e:c00:aa:bb:192.0.2.1- <|> try (do bs <- beforeEmbedded- embedded <- ip4' True- 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") @@ -603,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@@ -624,27 +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]+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+ [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 (SockAddrInet pn ha) = Just (IPv4 (fromHostAddress ha), pn) fromSockAddr (SockAddrInet6 pn _ ha6 _) = Just (IPv6 (fromHostAddress6 ha6), pn)-fromSockAddr _ = Nothing+fromSockAddr _ = Nothing -- | Convert 'IP' to 'SockAddr'. -- -- Since: 1.7.8. toSockAddr :: (IP, PortNumber) -> SockAddr-toSockAddr (IPv4 addr4, pn) = SockAddrInet pn (toHostAddress addr4)+toSockAddr (IPv4 addr4, pn) = SockAddrInet pn (toHostAddress addr4) toSockAddr (IPv6 addr6, pn) = SockAddrInet6 pn 0 (toHostAddress6 addr6) 0
Data/IP/Builder.hs view
@@ -1,40 +1,43 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StrictData #-}-{-# LANGUAGE NoStrict #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoStrict #-} -module Data.IP.Builder- ( -- * 'P.BoundedPrim' 'B.Builder's for general, IPv4 and IPv6 addresses.- ipBuilder- , ipv4Builder- , ipv6Builder- ) where+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 Data.ByteString.Builder.Prim ((>$<), (>*<))-import GHC.Exts-import GHC.Word (Word8(..), Word16(..), Word32(..))+import GHC.Exts+import GHC.Word (Word16 (..), Word32 (..), Word8 (..)) -import Data.IP.Addr+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@@ -48,12 +51,17 @@ ipv4Bounded :: P.BoundedPrim Word32 ipv4Bounded =- quads >$< ((P.word8Dec >*< dotsep) >*< (P.word8Dec >*< dotsep))- >*< ((P.word8Dec >*< dotsep) >*< P.word8Dec)+ 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##)), ())+ 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 #-}@@ -63,27 +71,40 @@ -- 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 = CHL Word32 -- ^ :<h>:<l>- | HL Word32 -- ^ <h>:<l>- | NOP -- ^ nop- | COL -- ^ :- | CC -- ^ : :- | CLO Word32 -- ^ :<l>- | CHC Word32 -- ^ :<h>:- | HC Word32 -- ^ <h>:+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) ) )+ 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.@@ -114,43 +135,58 @@ -- 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:+ 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)+ 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_HL =+ ( \case+ HL w -> (hi16 w, fstUnit (lo16 w))+ _ -> undefined+ )+ >$< P.word16Hex >*< colsep >*< P.word16Hex --- build_NOP = P.emptyB+ build_NOP = P.emptyB --- build_COL = const () >$< colsep+ build_COL = const () >$< colsep --- build_CC = const ((), ()) >$< colsep >*< colsep+ build_CC = const ((), ()) >$< colsep >*< colsep --- build_CLO = ( \ case CLO w -> fstUnit (lo16 w)- _ -> undefined )- >$< colsep >*< P.word16Hex+ 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_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+ build_HC =+ ( \case+ HC w -> sndUnit (hi16 w)+ _ -> undefined+ )+ >$< P.word16Hex >*< colsep -- static encoders --@@ -160,16 +196,16 @@ ffff :: P.BoundedPrim a ffff = toB $ const 0xffff >$< P.word16HexFixed - -- | Helpers+ -- \| 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 = ((), )+ fstUnit = ((),) -- sndUnit :: a -> (a, ())- sndUnit = (, ())+ sndUnit = (,()) -- pairPair (a, b, c, d) = ((a, b), (c, d)) @@ -184,54 +220,66 @@ makeF0 (I# gapStart) (I# gapEnd) !w = case (gapEnd ==# 0#) `orI#` (gapStart ># 1#) of- 1# -> HL w- _ -> case gapStart ==# 0# of- 1# -> COL- _ -> HC w+ 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+ 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+ 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))))))))))+ ( 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# }+ 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,@@ -239,13 +287,14 @@ -- 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+ 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.@@ -253,10 +302,11 @@ 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)+ 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)
Data/IP/Internal.hs view
@@ -1,9 +1,10 @@-module Data.IP.Internal ( IPv4(..)- , IPv6(..)- , AddrRange(..)- , IPv4Addr- , IPv6Addr- ) where+module Data.IP.Internal (+ IPv4 (..),+ IPv6 (..),+ AddrRange (..),+ IPv4Addr,+ IPv6Addr,+) where import Data.IP.Addr import Data.IP.Range
Data/IP/Mask.hs view
@@ -10,30 +10,32 @@ maskIPv6 :: Int -> IPv6 maskIPv6 len =- IP6 $ toIP6Addr $ bimapTup complement $- (0xffffffffffffffff, 0xffffffffffffffff) `shift128` (-len)- where- bimapTup f (x,y) = (f x, f y)+ IP6 $+ toIP6Addr $+ bimapTup complement $+ (0xffffffffffffffff, 0xffffffffffffffff) `shift128` (-len)+ where+ bimapTup f (x, y) = (f x, f y) shift128 :: (Word64, Word64) -> Int -> (Word64, Word64) shift128 x i- | i < 0 = x `shiftR128` (-i)- | i > 0 = x `shiftL128` i+ | i < 0 = x `shiftR128` (-i)+ | i > 0 = x `shiftL128` i | otherwise = x shiftL128 :: (Word64, Word64) -> Int -> (Word64, Word64) shiftL128 (h, l) i =- ( (h `shiftL` i) .|. (l `shift` (i - 64) ), (l `shiftL` i))+ ((h `shiftL` i) .|. (l `shift` (i - 64)), (l `shiftL` i)) shiftR128 :: (Word64, Word64) -> Int -> (Word64, Word64) shiftR128 (h, l) i =- (h `shiftR` i, (l `shiftR` i) .|. h `shift` (64 - 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- )+ ( (fromIntegral w3 `shiftL` 32) .|. fromIntegral w2+ , (fromIntegral w1 `shiftL` 32) .|. fromIntegral w0+ ) toIP6Addr :: (Word64, Word64) -> IPv6Addr toIP6Addr (h, l) =@@ -42,4 +44,5 @@ , fromIntegral $ (l `shiftR` 32) .&. m , fromIntegral $ l .&. m )- where m = 0xffffffff+ where+ m = 0xffffffff
Data/IP/Op.hs view
@@ -7,116 +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 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-- -}+ -- |+ --+ -- 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- masked = maskedIPv6+ 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 '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--}-+-- |+-- 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::/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)+ 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.+ [i1, i2, i3, i4] = fromIPv4 ip ->>> addrRangePair ("127.0.0.0/8" :: AddrRange IPv4)-(127.0.0.0,8)->>> addrRangePair ("2000::/8" :: AddrRange IPv6)-(2000::,8)--}+-- |+-- 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,7 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+ module Data.IP.Range where import Data.Bits@@ -11,52 +12,50 @@ import Data.IP.Mask import Data.String import Data.Typeable (Typeable)-import Text.Appar.String 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, Ord, Data, Generic, Typeable)+-- |+-- 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::/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+-- |+-- 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) @@ -80,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@@ -93,28 +92,29 @@ 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+ 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+ let n' = n * 10 + ord d - 48+ in if n' <= maxLen then f n' else Nothing ip4range :: Parser (AddrRange IPv4) ip4range = do@@ -130,16 +130,14 @@ ip6range :: Parser (AddrRange IPv6) ip6range = do- ip <- ip6+ ip <- ip6' False len <- maskLen 128 let msk = maskIPv6 len adr = ip `maskedIPv6` msk return $ AddrRange adr msk 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,28 +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- , I.lookupKeyValue- , I.lookupAll- , findMatch- , fromList, toList- , foldlWithKey- , foldrWithKey- ) 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,20 +1,19 @@-{-# LANGUAGE CPP #-}+{-# 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.--}+-- |+-- 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.Foldable (Foldable (..)) import Data.IP.Addr import Data.IP.Op import Data.IP.Range@@ -32,20 +31,18 @@ ---------------------------------------------------------------- -{-|- 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@@ -54,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) ---------------------------------------------------------------- --@@ -71,40 +68,38 @@ 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, Generic, Generic1, 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 @@ -135,45 +130,49 @@ ---------------------------------------------------------------- -{-|- 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+-- |+-- 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 @@ -185,161 +184,163 @@ ---------------------------------------------------------------- -{-|- 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 = fmap snd (search k s Nothing) -{-|- 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)+-- |+-- 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+ :: 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+ | 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--{-|- '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)]--}+ | 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 +-- |+-- '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+ | 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-+ | k == range = (k, v) : acc+ | k >:> range = go ((k, v) : acc) $ if isLeft range tb then l else r+ | otherwise = acc ---------------------------------------------------------------- -{-|- 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)+-- |+-- 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 <|> findMatch k1 r- | k2 >:> k1 = findMatch k1 l <|> findMatch k1 r- | otherwise = A.empty+ | 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 = pure (k2, vl) <|> findMatch k1 l <|> findMatch k1 r- | k2 >:> k1 = findMatch k1 l <|> findMatch k1 r- | otherwise = A.empty+ | 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 ----------------------------------------------------------------
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
iproute.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: iproute-version: 1.7.14+version: 1.7.15 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
test/BuilderSpec.hs view
@@ -33,7 +33,6 @@ -- 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 @@ -42,14 +41,14 @@ func <$> replicateM adrlen biased where biased = do- n <- choose(0, range)+ 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+ then return n+ else do+ f <- choose (0, 15 :: Int)+ if f < 15+ then return 0+ else return width ---------------------------------------------------------------- --
test/IPSpec.hs view
@@ -8,6 +8,7 @@ import Control.Applicative #endif import Data.IP+import Data.Maybe (isJust) import Safe (readMay) import Test.Hspec import Test.Hspec.QuickCheck (prop)@@ -23,13 +24,19 @@ data InvalidIPv4Str = Iv4 String deriving (Show) instance Arbitrary InvalidIPv4Str where- 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)- ]+ 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@@ -70,7 +77,11 @@ 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+ (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
@@ -8,11 +8,11 @@ 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 qualified Data.Foldable as Foldable-import Data.List (sort, nub)+import Data.List (nub, sort) import qualified Data.List as List import Data.Monoid ((<>)) import Test.Hspec@@ -40,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) ---------------------------------------------------------------- --@@ -50,18 +50,24 @@ 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@@ -77,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@@ -94,25 +100,28 @@ -- 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_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_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)+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)