diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -490,26 +490,23 @@ -- 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' :: Parser [Int] ip4' = do - as <- dig `sepBy1` char '.' - check as + as <- octet `sepBy1` char '.' + when (length as /= 4) (fail "IPv4 address") return as - where - test errmsg adr = when (adr < 0 || 255 < adr) (fail errmsg) - check as = do - let errmsg = "IPv4 address" - when (length as /= 4) (fail errmsg) - mapM_ (test errmsg) as skipSpaces :: Parser () skipSpaces = void $ many (char ' ') diff --git a/Data/IP/Builder.hs b/Data/IP/Builder.hs --- a/Data/IP/Builder.hs +++ b/Data/IP/Builder.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} @@ -52,9 +53,9 @@ where quads a = ((qdot 0o30# a, qdot 0o20# a), (qdot 0o10# a, qfin a)) {-# INLINE quads #-} - qdot s (W32# a) = (W8# ((a `uncheckedShiftRL#` s) `and#` 0xff##), ()) + qdot s (W32# a) = (W8# (wordToWord8Compat# ((word32ToWordCompat# a `uncheckedShiftRL#` s) `and#` 0xff##)), ()) {-# INLINE qdot #-} - qfin (W32# a) = W8# (a `and#` 0xff##) + qfin (W32# a) = W8# (wordToWord8Compat# (word32ToWordCompat# a `and#` 0xff##)) {-# INLINE qfin #-} dotsep = const 0x2e >$< toB P.word8 @@ -124,11 +125,13 @@ -- encoders for the eight field format (FF) cases. -- - build_CHL = (\ (CHL w) -> ( fstUnit (hi16 w), fstUnit (lo16 w) ) ) + build_CHL = ( \ case CHL w -> ( fstUnit (hi16 w), fstUnit (lo16 w) ) + _ -> undefined ) >$< (colsep >*< P.word16Hex) >*< (colsep >*< P.word16Hex) -- - build_HL = (\ (HL w) -> ( hi16 w, fstUnit (lo16 w) ) ) + build_HL = ( \ case HL w -> ( hi16 w, fstUnit (lo16 w) ) + _ -> undefined ) >$< P.word16Hex >*< colsep >*< P.word16Hex -- build_NOP = P.emptyB @@ -137,13 +140,16 @@ -- build_CC = const ((), ()) >$< colsep >*< colsep -- - build_CLO = (\ (CLO w) -> fstUnit (lo16 w) ) + build_CLO = ( \ case CLO w -> fstUnit (lo16 w) + _ -> undefined ) >$< colsep >*< P.word16Hex -- - build_CHC = (\ (CHC w) -> fstUnit (sndUnit (hi16 w)) ) + build_CHC = ( \ case CHC w -> fstUnit (sndUnit (hi16 w)) + _ -> undefined ) >$< colsep >*< P.word16Hex >*< colsep -- - build_HC = (\ (HC w) -> sndUnit (hi16 w)) + build_HC = ( \ case HC w -> sndUnit (hi16 w) + _ -> undefined ) >$< P.word16Hex >*< colsep -- static encoders @@ -156,8 +162,8 @@ -- | Helpers hi16, lo16 :: Word32 -> Word16 - hi16 !(W32# w) = W16# (w `uncheckedShiftRL#` 16#) - lo16 !(W32# w) = W16# (w `and#` 0xffff##) + hi16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `uncheckedShiftRL#` 16#)) + lo16 !(W32# w) = W16# (wordToWord16Compat# (word32ToWordCompat# w `and#` 0xffff##)) -- fstUnit :: a -> ((), a) fstUnit = ((), ) @@ -212,14 +218,14 @@ bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int) bestgap !(W32# a0) !(W32# a1) !(W32# a2) !(W32# a3) = finalGap - (updateGap (0xffff## `and#` a3) - (updateGap (0xffff0000## `and#` a3) - (updateGap (0xffff## `and#` a2) - (updateGap (0xffff0000## `and#` a2) - (updateGap (0xffff## `and#` a1) - (updateGap (0xffff0000## `and#` a1) - (updateGap (0xffff## `and#` a0) - (initGap (0xffff0000## `and#` a0))))))))) + (updateGap (0xffff## `and#` (word32ToWordCompat# a3)) + (updateGap (0xffff0000## `and#` (word32ToWordCompat# a3)) + (updateGap (0xffff## `and#` (word32ToWordCompat# a2)) + (updateGap (0xffff0000## `and#` (word32ToWordCompat# a2)) + (updateGap (0xffff## `and#` (word32ToWordCompat# a1)) + (updateGap (0xffff0000## `and#` (word32ToWordCompat# a1)) + (updateGap (0xffff## `and#` (word32ToWordCompat# a0)) + (initGap (0xffff0000## `and#` (word32ToWordCompat# a0)))))))))) where -- The state after the first input word is always i' = 7, @@ -252,3 +258,23 @@ 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/Range.hs b/Data/IP/Range.hs --- a/Data/IP/Range.hs +++ b/Data/IP/Range.hs @@ -1,10 +1,11 @@ +{-# 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 @@ -102,16 +103,26 @@ (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 + 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) @@ -119,13 +130,10 @@ ip6range :: Parser (AddrRange IPv6) ip6range = do ip <- ip6 - len <- option 128 $ char '/' >> dig - check len + 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) diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -1,5 +1,5 @@ Name: iproute -Version: 1.7.11 +Version: 1.7.12 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/test/IPSpec.hs b/test/IPSpec.hs --- a/test/IPSpec.hs +++ b/test/IPSpec.hs @@ -56,8 +56,12 @@ 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 to_str_ipv4 :: AddrRange IPv4 -> Bool to_str_ipv4 a = readMay (show a) == Just a