diff --git a/Data/IP.hs b/Data/IP.hs --- a/Data/IP.hs +++ b/Data/IP.hs @@ -34,7 +34,7 @@ AddrRange (addr, mask, mlen), -- * Address class - Addr (..), + Addr (masked, intToMask), makeAddrRange, (>:>), isMatchedTo, diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -8,15 +8,14 @@ import Data.Bits import Data.Char import Data.Data (Data) -import Data.List (foldl', intersperse) +import qualified Data.List as L import Data.String -import Data.Typeable (Typeable) import Data.Word -import GHC.Enum (predError, succError) +import GHC.ByteOrder (ByteOrder (..), targetByteOrder) +import GHC.Enum (fromEnumError, predError, succError, toEnumError) import GHC.Generics import Network.Socket import Numeric (showHex, showInt) -import System.ByteOrder import Text.Appar.String ---------------------------------------------------------------- @@ -32,7 +31,7 @@ data IP = IPv4 {ipv4 :: IPv4} | IPv6 {ipv6 :: IPv6} - deriving (Data, Generic, Typeable) + deriving (Data, Generic) -- | -- Equality over IP addresses. Correctly compare IPv4 and IPv4-embedded-in-IPv6 addresses. @@ -82,7 +81,7 @@ -- >>> read "192.0.2.1" :: IPv4 -- 192.0.2.1 newtype IPv4 = IP4 IPv4Addr - deriving (Eq, Ord, Bounded, Data, Generic, Typeable) + deriving (Eq, Ord, Bounded, Data, Generic) -- | -- The abstract data type to express an IPv6 address. @@ -103,32 +102,51 @@ -- >>> read "::0.0.0.1" :: IPv6 -- ::1 newtype IPv6 = IP6 IPv6Addr - deriving (Eq, Ord, Bounded, Data, Generic, Typeable) + deriving (Eq, Ord, Bounded, Data, Generic) ---------------------------------------------------------------- -- -- Enum -- +-- | Delegates to 'Word32', which stops at 'minBound' and 'maxBound'. +-- +-- >>> [read "255.255.255.254" ..] :: [IPv4] +-- [255.255.255.254,255.255.255.255] +-- >>> [read "0.0.0.1", read "0.0.0.0" ..] :: [IPv4] +-- [0.0.0.1,0.0.0.0] +-- >>> [read "192.0.2.2" .. read "192.0.2.1"] :: [IPv4] +-- [] instance Enum IPv4 where fromEnum (IP4 a) = fromEnum a toEnum = IP4 . toEnum + succ (IP4 a) = IP4 (succ a) + pred (IP4 a) = IP4 (pred a) + enumFrom (IP4 a) = IP4 <$> enumFrom a + enumFromTo (IP4 a) (IP4 b) = IP4 <$> enumFromTo a b + enumFromThen (IP4 a) (IP4 b) = IP4 <$> enumFromThen a b + enumFromThenTo (IP4 a) (IP4 b) (IP4 c) = IP4 <$> enumFromThenTo a b c +-- | Stops at 'minBound' and 'maxBound'. +-- 'fromEnum' and 'toEnum' fail if the address does not fit in 'Int'. +-- +-- >>> [read "ffff:ffff:ffff:ffff:ffff:ffff:ffff:fffe" ..] :: [IPv6] +-- [ffff:ffff:ffff:ffff:ffff:ffff:ffff:fffe,ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff] +-- >>> [read "::2", read "::1" ..] :: [IPv6] +-- [::2,::1,::] +-- >>> [read "::2" .. read "::1"] :: [IPv6] +-- [] +-- >>> fromEnum (read "::1:0" :: IPv6) +-- 65536 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 ip + | i > toInteger (maxBound :: Int) = fromEnumError "IPv6" ip + | otherwise = fromInteger i + where + i = ip6ToInteger ip + toEnum i + | i < 0 = toEnumError "IPv6" i (minBound :: IPv6, maxBound :: IPv6) + | otherwise = integerToIP6 (toInteger i) succ (IP6 (0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff)) = succError "IPv6" succ (IP6 (a, 0xffffffff, 0xffffffff, 0xffffffff)) = IP6 (succ a, 0, 0, 0) @@ -142,24 +160,28 @@ 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 = enumFromTo ip maxBound - enumFromTo ip ip' = ip : gen ip + enumFromTo ip ip' + | ip > ip' = [] + | otherwise = 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] + enumFromThen ip ip' + | ip' >= ip = enumFromThenTo ip ip' maxBound + | otherwise = enumFromThenTo ip ip' minBound + -- Integer's enumFromThenTo never goes beyond the bounds given. + enumFromThenTo ip inc fin = + integerToIP6 <$> [ip6ToInteger ip, ip6ToInteger inc .. ip6ToInteger fin] + +-- | Mixed families are enumerated as IPv6, as in 'Eq' and 'Ord'. +-- +-- >>> [IPv4 (read "192.0.2.1") .. IPv6 (read "::ffff:192.0.2.2")] +-- [::ffff:192.0.2.1,::ffff:192.0.2.2] instance Enum IP where fromEnum (IPv4 ip) = fromEnum ip fromEnum (IPv6 ip) = fromEnum ip @@ -173,21 +195,22 @@ 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 + enumFrom (IPv4 ip) = IPv4 <$> enumFrom ip + enumFrom (IPv6 ip) = 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" + enumFromTo (IPv4 ip) (IPv4 ip') = IPv4 <$> enumFromTo ip ip' + enumFromTo ip ip' = IPv6 <$> enumFromTo (toV6 ip) (toV6 ip') - 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" + enumFromThen (IPv4 ip) (IPv4 ip') = IPv4 <$> enumFromThen ip ip' + enumFromThen ip ip' = IPv6 <$> enumFromThen (toV6 ip) (toV6 ip') - 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" + enumFromThenTo (IPv4 ip) (IPv4 inc) (IPv4 fin) = IPv4 <$> enumFromThenTo ip inc fin + enumFromThenTo ip inc fin = IPv6 <$> enumFromThenTo (toV6 ip) (toV6 inc) (toV6 fin) +toV6 :: IP -> IPv6 +toV6 (IPv4 ip) = ipv4ToIPv6 ip +toV6 (IPv6 ip) = ip + ip6ToInteger :: IPv6 -> Integer ip6ToInteger (IP6 (a, b, c, d)) = let a' = word32ToInteger a `shift` 96 @@ -223,7 +246,7 @@ -- | Show an IPv4 address in the dot-decimal notation. showIPv4 :: IPv4 -> ShowS -showIPv4 = foldr1 (.) . intersperse (showChar '.') . map showInt . fromIPv4 +showIPv4 = foldr1 (.) . L.intersperse (showChar '.') . map showInt . fromIPv4 -- | Show an IPv6 address in the most appropriate notation, based on recommended -- representation proposed by . @@ -246,7 +269,7 @@ showFields fields where fields = fromIPv6 ip - showFields = foldr (.) id . intersperse (showChar ':') . map showHex + showFields = foldr (.) id . L.intersperse (showChar ':') . map showHex prefix = take begin fields -- fields before "::" suffix = drop end fields -- fields after "::" begin = end + diff -- the longest run of zeros @@ -392,7 +415,7 @@ -- >>> 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 : [] +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 @@ -465,12 +488,29 @@ -- Read -- +-- | +-- >>> read "[192.0.2.1,2001:db8::1]" :: [IP] +-- [192.0.2.1,2001:db8::1] instance Read IP where readsPrec _ = parseIP +-- | 'reads' returns the rest of the input. +-- +-- >>> reads "192.0.2.1 rest" :: [(IPv4, String)] +-- [(192.0.2.1," rest")] +-- >>> read "(192.0.2.1,80)" :: (IPv4, Int) +-- (192.0.2.1,80) +-- >>> reads "192.0.2.1a" :: [(IPv4, String)] +-- [] instance Read IPv4 where readsPrec _ = parseIPv4 +-- | 'reads' returns the rest of the input. +-- +-- >>> reads "::192.0.2.1 rest" :: [(IPv6, String)] +-- [(::192.0.2.1," rest")] +-- >>> read "[::1,2001:db8::1]" :: [IPv6] +-- [::1,2001:db8::1] instance Read IPv6 where readsPrec _ = parseIPv6 @@ -521,10 +561,10 @@ in if n' <= 255 then f n' else Nothing ip4 :: Parser IPv4 -ip4 = skipSpaces >> toIPv4 <$> ip4' True +ip4 = skipSpaces >> toIPv4 <$> ip4' -ip4' :: Bool -> Parser [Int] -ip4' checkTermination = do +ip4' :: Parser [Int] +ip4' = do a0 <- octet _ <- char '.' a1 <- octet @@ -532,18 +572,18 @@ a2 <- octet _ <- char '.' a3 <- octet - let as = [a0, a1, a2, a3] - when checkTermination $ - skipSpaces >> termination - return as + boundary + return [a0, a1, a2, a3] skipSpaces :: Parser () skipSpaces = void $ many (char ' ') -termination :: Parser () -termination = P $ \str -> case str of - [] -> (Just (), "") - _ -> (Nothing, str) +-- | Succeeds without consuming input if the address cannot continue here, +-- so that 'readsPrec' can return the rest of the input. +boundary :: Parser () +boundary = P $ \str -> case str of + c : _ | isHexDigit c || c == '.' || c == ':' -> (Nothing, str) + _ -> (Just (), str) ---------------------------------------------------------------- -- @@ -555,7 +595,7 @@ ns <- some hexDigit check ns let ms = map digitToInt ns - val = foldl' (\x y -> x * 16 + y) 0 ms + val = L.foldl' (\x y -> x * 16 + y) 0 ms return val where check ns = when (length ns > 4) (fail "IPv6 address -- more than 4 hex") @@ -575,42 +615,44 @@ return $ bs1 ++ spring ++ bs2 ip6 :: Parser IPv6 -ip6 = ip6' True - -ip6' :: Bool -> Parser IPv6 -ip6' checkTermination = skipSpaces >> toIPv6 <$> ip6arr +ip6 = skipSpaces >> toIPv6 <$> ip6arr where + -- appar's <|> does not backtrack, so each branch is wrapped in try. ip6arr = - ip4Embedded' checkTermination - <|> do - colon2 - bs <- option [] hexcolon - format [] bs + ip4Embedded <|> try ( do + colon2 + bs <- option [] hexcolon + boundary + format [] bs + ) + <|> try + ( do rs <- hexcolon + boundary check rs return rs ) - <|> do - bs1 <- hexcolon2 - bs2 <- option [] hexcolon - format bs1 bs2 + <|> try + ( do + bs1 <- hexcolon2 + bs2 <- option [] hexcolon + boundary + 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 = ip4Embedded' True - -ip4Embedded' :: Bool -> Parser [Int] -ip4Embedded' checkTermination = +ip4Embedded = try ( do colon2 bs <- beforeEmbedded - embedded <- ip4' checkTermination + embedded <- ip4' format [] (bs ++ ip4ToIp6 embedded) ) -- matches 2001:db8::192.0.2.1 @@ -618,14 +660,14 @@ ( do bs1 <- manyTill (try $ hex <* char ':') (char ':') bs2 <- option [] beforeEmbedded - embedded <- ip4' checkTermination + embedded <- ip4' format bs1 (bs2 ++ ip4ToIp6 embedded) ) -- matches 2001:db8:11e:c00:aa:bb:192.0.2.1 <|> try ( do bs <- beforeEmbedded - embedded <- ip4' checkTermination + embedded <- ip4' let rs = bs ++ ip4ToIp6 embedded check rs return rs @@ -647,13 +689,13 @@ -- | The 'fromHostAddress' function converts 'HostAddress' to 'IPv4'. fromHostAddress :: HostAddress -> IPv4 fromHostAddress addr4 - | byteOrder == LittleEndian = IP4 $ fixByteOrder addr4 + | targetByteOrder == LittleEndian = IP4 $ byteSwap32 addr4 | otherwise = IP4 addr4 -- | The 'toHostAddress' function converts 'IPv4' to 'HostAddress'. toHostAddress :: IPv4 -> HostAddress toHostAddress (IP4 addr4) - | byteOrder == LittleEndian = fixByteOrder addr4 + | targetByteOrder == LittleEndian = byteSwap32 addr4 | otherwise = addr4 -- | The 'fromHostAddress6' function converts 'HostAddress6' to 'IPv6'. @@ -664,19 +706,9 @@ toHostAddress6 :: IPv6 -> HostAddress6 toHostAddress6 (IP6 addr6) = addr6 -fixByteOrder :: Word32 -> Word32 -fixByteOrder s = d1 .|. d2 .|. d3 .|. d4 - where - d1 = shiftL s 24 - 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 +ipv4ToIPv6 (IP4 w) = IP6 (0, 0, 0xffff, w) -- | Convert 'SockAddr' to 'IP'. -- diff --git a/Data/IP/Builder.hs b/Data/IP/Builder.hs --- a/Data/IP/Builder.hs +++ b/Data/IP/Builder.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoStrict #-} @@ -34,13 +31,13 @@ -- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv4' addresses. ipv4Builder :: IPv4 -> B.Builder -ipv4Builder addr = P.primBounded ipv4Bounded $! fromIPv4w addr +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 +ipv6Builder addr = P.primBounded ipv6Bounded $ fromIPv6w addr ------------ Builder utilities @@ -59,11 +56,11 @@ {-# INLINE quads #-} qdot s (W32# a) = ( W8# - (wordToWord8Compat# ((word32ToWordCompat# a `uncheckedShiftRL#` s) `and#` 0xff##)) + (wordToWord8# ((word32ToWord# a `uncheckedShiftRL#` s) `and#` 0xff##)) , () ) {-# INLINE qdot #-} - qfin (W32# a) = W8# (wordToWord8Compat# (word32ToWordCompat# a `and#` 0xff##)) + qfin (W32# a) = W8# (wordToWord8# (word32ToWord# a `and#` 0xff##)) {-# INLINE qfin #-} dotsep = const 0x2e >$< toB P.word8 @@ -129,7 +126,7 @@ -- output128 :: P.BoundedPrim ((FF, FF), (FF, FF)) output128 = output64 >*< output64 - output64 = (output32 >*< output32) + output64 = output32 >*< output32 -- -- And finally the per-word case-work. -- @@ -141,7 +138,9 @@ 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: + P.condB + (\case CHC _ -> True; _ -> False) + build_CHC -- :hi: build_HC -- hi: -- encoders for the eight field format (FF) cases. @@ -198,8 +197,8 @@ -- \| Helpers hi16, lo16 :: Word32 -> Word16 - hi16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `uncheckedShiftRL#` 16#)) - lo16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `and#` 0xffff##)) + hi16 (W32# w) = W16# (wordToWord16# (word32ToWord# w `uncheckedShiftRL#` 16#)) + lo16 (W32# w) = W16# (wordToWord16# (word32ToWord# w `and#` 0xffff##)) -- fstUnit :: a -> ((), a) fstUnit = ((),) @@ -211,14 +210,14 @@ -- 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 + 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 = + makeF0 (I# gapStart) (I# gapEnd) w = case (gapEnd ==# 0#) `orI#` (gapStart ># 1#) of 1# -> HL w _ -> case gapStart ==# 0# of @@ -226,7 +225,7 @@ _ -> HC w {-# INLINE makeF0 #-} - makeF12 (I# gapStart) (I# gapEnd) il ir !w = + makeF12 (I# gapStart) (I# gapEnd) il ir w = case (gapEnd <=# il) `orI#` (gapStart ># ir) of 1# -> CHL w _ -> case gapStart >=# il of @@ -238,7 +237,7 @@ _ -> CLO w {-# INLINE makeF12 #-} - makeF3 (I# gapStart) (I# gapEnd) !w = + makeF3 (I# gapStart) (I# gapEnd) w = case gapEnd <=# 6# of 1# -> CHL w _ -> case gapStart ==# 6# of @@ -251,23 +250,23 @@ -- | 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) = +bestgap (W32# a0) (W32# a1) (W32# a2) (W32# a3) = finalGap ( updateGap - (0xffff## `and#` (word32ToWordCompat# a3)) + (0xffff## `and#` word32ToWord# a3) ( updateGap - (0xffff0000## `and#` (word32ToWordCompat# a3)) + (0xffff0000## `and#` word32ToWord# a3) ( updateGap - (0xffff## `and#` (word32ToWordCompat# a2)) + (0xffff## `and#` word32ToWord# a2) ( updateGap - (0xffff0000## `and#` (word32ToWordCompat# a2)) + (0xffff0000## `and#` word32ToWord# a2) ( updateGap - (0xffff## `and#` (word32ToWordCompat# a1)) + (0xffff## `and#` word32ToWord# a1) ( updateGap - (0xffff0000## `and#` (word32ToWordCompat# a1)) + (0xffff0000## `and#` word32ToWord# a1) ( updateGap - (0xffff## `and#` (word32ToWordCompat# a0)) - (initGap (0xffff0000## `and#` (word32ToWordCompat# a0))) + (0xffff## `and#` word32ToWord# a0) + (initGap (0xffff0000## `and#` word32ToWord# a0)) ) ) ) @@ -308,23 +307,3 @@ 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/Mask.hs b/Data/IP/Mask.hs --- a/Data/IP/Mask.hs +++ b/Data/IP/Mask.hs @@ -25,7 +25,7 @@ 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 = diff --git a/Data/IP/Op.hs b/Data/IP/Op.hs --- a/Data/IP/Op.hs +++ b/Data/IP/Op.hs @@ -1,6 +1,5 @@ module Data.IP.Op where -import Data.Bits import Data.IP.Addr import Data.IP.Mask import Data.IP.Range @@ -36,13 +35,18 @@ -- ::ffff intToMask :: Int -> a + -- | The number of bits of the address. The argument is not evaluated. + addrBits :: a -> Int + instance Addr IPv4 where masked = maskedIPv4 intToMask = maskIPv4 + addrBits _ = 32 instance Addr IPv6 where masked = maskedIPv6 intToMask = maskIPv6 + addrBits _ = 128 ---------------------------------------------------------------- @@ -81,26 +85,29 @@ -- 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. +-- A mask length out of range is clamped to it. -- -- >>> 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 (toIPv4 [127,0,2,1]) 40 +-- 127.0.2.1/32 +-- >>> makeAddrRange (toIPv4 [127,0,2,1]) (-1) +-- 0.0.0.0/0 makeAddrRange :: Addr a => a -> Int -> AddrRange a -makeAddrRange ad len = AddrRange adr msk len +makeAddrRange ad len0 = AddrRange adr msk len where + len = max 0 $ min (addrBits ad) len0 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 (ipv4ToIPv6 ip) (masklen + 96) where (ip, masklen) = addrRangePair range - [i1, i2, i3, i4] = fromIPv4 ip -- | -- The 'unmakeAddrRange' functions take a 'AddrRange' and diff --git a/Data/IP/Range.hs b/Data/IP/Range.hs --- a/Data/IP/Range.hs +++ b/Data/IP/Range.hs @@ -11,7 +11,6 @@ import Data.IP.Addr import Data.IP.Mask import Data.String -import Data.Typeable (Typeable) import GHC.Generics import Text.Appar.String @@ -26,11 +25,31 @@ -- 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 +-- >>> (read "192.0.2.0/24" :: IPRange) == (read "::ffff:192.0.2.0/120" :: IPRange) +-- True data IPRange = IPv4Range {ipv4range :: AddrRange IPv4} | IPv6Range {ipv6range :: AddrRange IPv6} - deriving (Eq, Ord, Data, Generic, Typeable) + deriving (Data, Generic) +-- | Like 'IP', an IPv4 range is equal to its IPv4-mapped IPv6 range. +instance Eq IPRange where + IPv4Range r1 == IPv4Range r2 = r1 == r2 + IPv6Range r1 == IPv6Range r2 = r1 == r2 + IPv4Range r1 == IPv6Range r2 = mapRange r1 == r2 + IPv6Range r1 == IPv4Range r2 = r1 == mapRange r2 + +instance Ord IPRange where + IPv4Range r1 `compare` IPv4Range r2 = r1 `compare` r2 + IPv6Range r1 `compare` IPv6Range r2 = r1 `compare` r2 + IPv4Range r1 `compare` IPv6Range r2 = mapRange r1 `compare` r2 + IPv6Range r1 `compare` IPv4Range r2 = r1 `compare` mapRange r2 + +mapRange :: AddrRange IPv4 -> AddrRange IPv6 +mapRange (AddrRange a _ len) = AddrRange (ipv4ToIPv6 a) (maskIPv6 len') len' + where + len' = len + 96 + ---------------------------------------------------------------- -- -- Range @@ -57,7 +76,7 @@ , mlen :: {-# UNPACK #-} !Int -- ^ The 'mlen' function returns a mask length from 'AddrRange'. } - deriving (Eq, Ord, Data, Generic, Typeable) + deriving (Eq, Ord, Data, Generic) ---------------------------------------------------------------- -- @@ -76,6 +95,9 @@ -- Read -- +-- | +-- >>> read "[192.0.2.0/24,2001:db8::/32]" :: [IPRange] +-- [192.0.2.0/24,2001:db8::/32] instance Read IPRange where readsPrec _ = parseIPRange @@ -86,6 +108,10 @@ (Just ip, rest) -> [(IPv6Range ip, rest)] (Nothing, _) -> [] +-- | 'reads' returns the rest of the input. +-- +-- >>> reads "192.0.2.0/24 rest" :: [(AddrRange IPv4, String)] +-- [(192.0.2.0/24," rest")] instance Read (AddrRange IPv4) where readsPrec _ = parseIPv4Range @@ -119,7 +145,7 @@ ip4range :: Parser (AddrRange IPv4) ip4range = do skipSpaces - ip <- toIPv4 <$> ip4' False + ip <- toIPv4 <$> ip4' len <- maskLen 32 let msk = maskIPv4 len adr = ip `maskedIPv4` msk @@ -130,7 +156,7 @@ ip6range :: Parser (AddrRange IPv6) ip6range = do - ip <- ip6' False + ip <- ip6 len <- maskLen 128 let msk = maskIPv6 len adr = ip `maskedIPv6` msk 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} -- | @@ -13,16 +12,14 @@ import qualified Control.Applicative as A (empty) import Control.Monad import Data.Bits -import Data.Foldable (Foldable (..)) import Data.IP.Addr +import Data.IP.Mask import Data.IP.Op import Data.IP.Range -import Data.IntMap (IntMap, (!)) -import qualified Data.IntMap as IM (fromList) +import qualified Data.List as L import Data.Monoid hiding ((<>)) import Data.Semigroup import Data.Traversable -import Data.Word import GHC.Generics (Generic, Generic1) import Prelude hiding (lookup) @@ -59,28 +56,10 @@ -- intToTBitIPv4 :: Int -> IPv4 -intToTBitIPv4 len = IP4 (intToTBitsIPv4 ! len) +intToTBitIPv4 len = IP4 (0x80000000 `shiftR` len) intToTBitIPv6 :: Int -> IPv6 -intToTBitIPv6 len = IP6 (intToTBitsIPv6 ! len) - -intToTBitsWord32 :: [Word32] -intToTBitsWord32 = iterate (`shift` (-1)) 0x80000000 - -intToTBitsIPv4 :: IntMap IPv4Addr -intToTBitsIPv4 = IM.fromList $ zip [0 .. 32] intToTBitsWord32 - -intToTBitsIPv6 :: IntMap IPv6Addr -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)] - intToTBits = take 32 intToTBitsWord32 - all0 = 0x00000000 +intToTBitIPv6 len = IP6 $ toIP6Addr $ (0x8000000000000000, 0) `shiftR128` len ---------------------------------------------------------------- @@ -330,17 +309,17 @@ -- 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 = L.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. +-- value from an IP routing table. The list is sorted by 'AddrRange'. +-- +-- >>> let rt = fromList [("10.128.0.0/16",3),("10.0.0.0/8",1),("10.1.0.0/16",2)] :: IPRTable IPv4 Int +-- >>> toList rt +-- [(10.0.0.0/8,1),(10.1.0.0/16,2),(10.128.0.0/16,3)] 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 +toList = foldrWithKey (\k a xs -> (k, a) : xs) [] ---------------------------------------------------------------- @@ -349,27 +328,35 @@ 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. +-- left-associative binary operator, in the order of 'AddrRange'. -- This function is equivalent to Data.Map.foldlWithKey with necessary to -- IPRTable changes. -- Since: 1.7.5 +-- +-- >>> let rt = fromList [("10.128.0.0/16",3),("10.0.0.0/8",1),("10.1.0.0/16",2)] :: IPRTable IPv4 Int +-- >>> foldlWithKey (\ks k _ -> k : ks) [] rt +-- [10.128.0.0/16,10.1.0.0/16,10.0.0.0/8] 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 + go z (Node n _ (Just v) l r) = go (go (f z n v) l) r {-# INLINE foldlWithKey #-} -- | /O(n)/. Fold the keys and values in the IPRTable using the given --- right-associative binary operator. +-- right-associative binary operator, in the order of 'AddrRange'. -- This function is equivalent to Data.Map.foldrWithKey with necessary to -- IPRTable changes. -- Since: 1.7.5 +-- +-- >>> let rt = fromList [("10.128.0.0/16",3),("10.0.0.0/8",1),("10.1.0.0/16",2)] :: IPRTable IPv4 Int +-- >>> foldrWithKey (\k _ ks -> k : ks) [] rt +-- [10.0.0.0/8,10.1.0.0/16,10.128.0.0/16] 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 + go z (Node n _ (Just v) l r) = f n v (go (go z r) l) {-# INLINE foldrWithKey #-} diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -1,13 +1,13 @@ -cabal-version: >=1.10 +cabal-version: 3.0 name: iproute -version: 1.7.15 -license: BSD3 +version: 1.8.0 +license: BSD-3-Clause 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 + ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 + ghc ==9.12.4 homepage: http://www.mew.org/~kazu/proj/iproute/ synopsis: IP Routing Table @@ -23,7 +23,7 @@ source-repository head type: git - location: git://github.com/kazu-yamamoto/iproute.git + location: https://github.com/kazu-yamamoto/iproute.git library exposed-modules: @@ -39,22 +39,15 @@ Data.IP.Op Data.IP.Range - default-language: Haskell2010 - ghc-options: -Wall + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall build-depends: - base >=4.9 && <5, + base >=4.16 && <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 @@ -68,16 +61,11 @@ default-language: Haskell2010 ghc-options: -Wall build-depends: - base >=4.6 && <5, + base >=4.16 && <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 --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -1,12 +1,8 @@ -{-# 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 diff --git a/test/IPSpec.hs b/test/IPSpec.hs --- a/test/IPSpec.hs +++ b/test/IPSpec.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module IPSpec where -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif +import Control.Exception (evaluate) import Data.IP -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Safe (readMay) import Test.Hspec import Test.Hspec.QuickCheck (prop) @@ -21,7 +19,7 @@ -- Arbitrary -- -data InvalidIPv4Str = Iv4 String deriving (Show) +newtype InvalidIPv4Str = Iv4 String deriving (Show) instance Arbitrary InvalidIPv4Str where arbitrary = @@ -47,7 +45,7 @@ toIv4 adr len = Iv4 $ show adr ++ "/" ++ show len lenGen = oneof [choose (minBound, -1), choose (msklen + 1, maxBound)] -data InvalidIPv6Str = Iv6 String deriving (Show) +newtype InvalidIPv6Str = Iv6 String deriving (Show) instance Arbitrary InvalidIPv6Str where arbitrary = arbitraryIIPv6Str arbitrary 128 @@ -82,7 +80,67 @@ it "can read embedded v4 in v6 range" $ do (readMay "::ffff:192.0.2.0/120" :: Maybe (AddrRange IPv6)) `shouldSatisfy` isJust + prop "lists of IP" $ \xs ys -> + let ips = map IPv4 xs ++ map IPv6 ys in readMay (show ips) == Just ips + prop "pairs of IPv4 and Int" $ \x n -> + readMay (show (x :: IPv4, n :: Int)) == Just (x, n) + prop "pairs of IPv6 and Int" $ \x n -> + readMay (show (x :: IPv6, n :: Int)) == Just (x, n) + prop "lists of IPRange" $ \xs ys -> + let rs = map IPv4Range xs ++ map IPv6Range ys + in readMay (show rs) == Just rs + it "returns the rest of the input" $ do + (reads "192.0.2.1 x" :: [(IPv4, String)]) + `shouldBe` [(read "192.0.2.1", " x")] + (reads "::192.0.2.1 x" :: [(IPv6, String)]) + `shouldBe` [(read "::192.0.2.1", " x")] + (reads "192.0.2.0/24 x" :: [(AddrRange IPv4, String)]) + `shouldBe` [(read "192.0.2.0/24", " x")] + it "does not stop in the middle of an address" $ do + (reads "192.0.2.1a" :: [(IPv4, String)]) `shouldBe` [] + (reads "1:2:3:4:5:6:7:8:9" :: [(IPv6, String)]) `shouldBe` [] + describe "makeAddrRange" $ do + it "clamps the mask length" $ do + makeAddrRange ("192.0.2.1" :: IPv4) 40 `shouldBe` "192.0.2.1/32" + makeAddrRange ("192.0.2.1" :: IPv4) (-1) `shouldBe` "0.0.0.0/0" + makeAddrRange ("2001:db8::1" :: IPv6) 200 `shouldBe` "2001:db8::1/128" + makeAddrRange ("2001:db8::1" :: IPv6) (-1) `shouldBe` "::/0" + prop "makes a valid IPv4 range" $ \a n -> + let r = makeAddrRange (a :: IPv4) n in readMay (show r) == Just r + prop "makes a valid IPv6 range" $ \a n -> + let r = makeAddrRange (a :: IPv6) n in readMay (show r) == Just r + describe "IPv4-mapped IPv6" $ do + prop "IPRange compares like IP" $ \x y -> + let r4 = IPv4Range x + r6 = IPv6Range (ipv4RangeToIPv6 y) + in (r4 == r6) == (x == y) && compare r4 r6 == compare x y + it "enumerates mixed families as IPv6" $ do + [IPv4 "192.0.2.1" .. IPv6 "::ffff:192.0.2.2"] + `shouldBe` [IPv6 "::ffff:192.0.2.1", IPv6 "::ffff:192.0.2.2"] + describe "enum" $ do + it "stops at maxBound" $ do + [maxBound ..] `shouldBe` [maxBound :: IPv4] + [maxBound ..] `shouldBe` [maxBound :: IPv6] + [pred maxBound, maxBound ..] `shouldBe` [pred maxBound, maxBound :: IPv4] + [pred maxBound, maxBound ..] `shouldBe` [pred maxBound, maxBound :: IPv6] + it "stops at minBound" $ do + [succ minBound, minBound ..] `shouldBe` [succ minBound, minBound :: IPv4] + [succ minBound, minBound ..] `shouldBe` [succ minBound, minBound :: IPv6] + it "returns [] for an empty range" $ do + ["::2" .. "::1"] `shouldBe` ([] :: [IPv6]) + ["0.0.0.2" .. "0.0.0.1"] `shouldBe` ([] :: [IPv4]) + it "converts IPv6 to Int and back" $ do + fromEnum ("::1:0" :: IPv6) `shouldBe` 0x10000 + toEnum 0x10000 `shouldBe` ("::1:0" :: IPv6) + it "rejects IPv6 which does not fit in Int" $ do + evaluate (fromEnum ("1::" :: IPv6)) `shouldThrow` anyErrorCall + evaluate (toEnum (-1) :: IPv6) `shouldThrow` anyErrorCall + prop "IPv6 enumFromTo is consistent with Integer" $ \x (Small n) -> + let y = toEnum (fromEnum (x :: IPv4) `mod` 0x10000) :: IPv6 + z = toEnum (fromEnum y + (abs n :: Int)) :: IPv6 + in map fromEnum [y .. z] == [fromEnum y .. fromEnum z] + to_str_ipv4 :: AddrRange IPv4 -> Bool to_str_ipv4 a = readMay (show a) == Just a @@ -90,7 +148,7 @@ to_str_ipv6 a = readMay (show a) == Just a ipv4_fail :: InvalidIPv4Str -> Bool -ipv4_fail (Iv4 a) = (readMay a :: Maybe (AddrRange IPv4)) == Nothing +ipv4_fail (Iv4 a) = isNothing (readMay a :: Maybe (AddrRange IPv4)) ipv6_fail :: InvalidIPv6Str -> Bool -ipv6_fail (Iv6 a) = (readMay a :: Maybe (AddrRange IPv6)) == Nothing +ipv6_fail (Iv6 a) = isNothing (readMay a :: Maybe (AddrRange IPv6)) diff --git a/test/RouteTableSpec.hs b/test/RouteTableSpec.hs --- a/test/RouteTableSpec.hs +++ b/test/RouteTableSpec.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module RouteTableSpec where -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative hiding (empty) -#endif import Control.Monad import qualified Data.Foldable as Foldable import Data.Function (on) @@ -14,7 +10,6 @@ import Data.IP.RouteTable.Internal 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 @@ -81,7 +76,7 @@ xs' = sort xs fromto_ip :: (Routable a, Ord a) => [AddrRange a] -> Bool -fromto_ip xs = nub (sort xs) == nub (sort ys) +fromto_ip xs = nub (sort xs) == ys where ys = map fst . toList . fromList $ zip xs xs @@ -101,25 +96,27 @@ -- Foldl and foldr properties are adapted from Data.Map tests prop_foldl :: Int -> [(AddrRange IPv4, Int)] -> Property prop_foldl n ys = - length ys > 0 ==> + not (null ys) ==> let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in Foldable.foldl (+) n m == List.foldr (+) n (List.map snd xs) + in Foldable.foldl (+) n m == List.foldr ((+) . snd) n 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) + && foldlWithKey (\b _ a -> a + b) n m == List.foldr ((+) . snd) n xs + && foldlWithKey (\b k a -> (k, a) : b) [] m == reverse (List.sort xs) prop_foldr :: Int -> [(AddrRange IPv4, Int)] -> Property prop_foldr n ys = - length ys > 0 ==> + not (null ys) ==> let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in Foldable.foldr (+) n m == List.foldr (+) n (List.map snd xs) + in Foldable.foldr (+) n m == List.foldr ((+) . snd) n 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) + && foldrWithKey (\_ a b -> a + b) n m == List.foldr ((+) . snd) n xs + && foldrWithKey (\k a b -> (k, a) : b) [] m == List.sort xs prop_monoid :: [(AddrRange IPv4, ())] -> [(AddrRange IPv4, ())] -> Property prop_monoid xs ys = - length xs > 0 && length ys > 0 ==> + not (null xs) && not (null ys) ==> let xm = fromList xs ym = fromList ys in empty <> xm == xm