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