diff --git a/Data/IP.hs b/Data/IP.hs --- a/Data/IP.hs +++ b/Data/IP.hs @@ -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 diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -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 diff --git a/Data/IP/Builder.hs b/Data/IP/Builder.hs --- a/Data/IP/Builder.hs +++ b/Data/IP/Builder.hs @@ -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 -- ^ :: - | HL Word32 -- ^ : - | NOP -- ^ nop - | COL -- ^ : - | CC -- ^ : : - | CLO Word32 -- ^ : - | CHC Word32 -- ^ :: - | HC Word32 -- ^ : +data FF + = -- | :: + CHL Word32 + | -- | : + HL Word32 + | -- | nop + NOP + | -- | : + COL + | -- | : : + CC + | -- | : + CLO Word32 + | -- | :: + CHC Word32 + | -- | : + 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) diff --git a/Data/IP/Internal.hs b/Data/IP/Internal.hs --- a/Data/IP/Internal.hs +++ b/Data/IP/Internal.hs @@ -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 diff --git a/Data/IP/Mask.hs b/Data/IP/Mask.hs --- a/Data/IP/Mask.hs +++ b/Data/IP/Mask.hs @@ -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 diff --git a/Data/IP/Op.hs b/Data/IP/Op.hs --- a/Data/IP/Op.hs +++ b/Data/IP/Op.hs @@ -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) diff --git a/Data/IP/Range.hs b/Data/IP/Range.hs --- a/Data/IP/Range.hs +++ b/Data/IP/Range.hs @@ -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) ---------------------------------------------------------------- -- diff --git a/Data/IP/RouteTable.hs b/Data/IP/RouteTable.hs --- a/Data/IP/RouteTable.hs +++ b/Data/IP/RouteTable.hs @@ -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: - --} +-- | +-- 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: +-- 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 diff --git a/Data/IP/RouteTable/Internal.hs b/Data/IP/RouteTable/Internal.hs --- a/Data/IP/RouteTable/Internal.hs +++ b/Data/IP/RouteTable/Internal.hs @@ -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 ---------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -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 diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -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 ---------------------------------------------------------------- -- diff --git a/test/IPSpec.hs b/test/IPSpec.hs --- a/test/IPSpec.hs +++ b/test/IPSpec.hs @@ -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 diff --git a/test/RouteTableSpec.hs b/test/RouteTableSpec.hs --- a/test/RouteTableSpec.hs +++ b/test/RouteTableSpec.hs @@ -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)