diff --git a/ip.cabal b/ip.cabal --- a/ip.cabal +++ b/ip.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ip -version: 1.7.0 +version: 1.7.1 synopsis: Library for IP and MAC addresses homepage: https://github.com/andrewthad/haskell-ip#readme license: BSD-3-Clause @@ -49,14 +49,14 @@ , aeson >= 1.0 && < 1.5 , attoparsec >= 0.13 && < 0.14 , base >= 4.9 && < 5 - , byteslice >= 0.1.2 && < 0.2 - , bytesmith >= 0.3 && < 0.4 + , byteslice >= 0.1.2 && < 0.3 + , bytesmith >= 0.3.3 && < 0.4 , bytestring >= 0.10.8 && < 0.11 , deepseq >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.4 , natural-arithmetic >= 0.1 && <0.2 , primitive >= 0.6.4 && < 0.8 - , small-bytearray-builder >= 0.2.1 && <0.4 + , small-bytearray-builder >= 0.3.2 && <0.4 , text >= 1.2 && < 1.3 , text-short >= 0.1.3 && < 0.2 , vector >= 0.11 && < 0.13 @@ -73,7 +73,7 @@ , QuickCheck , attoparsec , base - , byteslice >= 0.1.2 && < 0.2 + , byteslice , bytestring , ip , quickcheck-classes >= 0.4.13 && < 0.7.0.0 @@ -128,7 +128,9 @@ , bytestring , criterion , ip + , primitive , text + , random other-modules: IPv4ByteString1 IPv4DecodeText1 diff --git a/src/Net/IPv4.hs b/src/Net/IPv4.hs --- a/src/Net/IPv4.hs +++ b/src/Net/IPv4.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -76,6 +77,9 @@ , builderRange , parserRange , printRange + -- ** UTF-8 Bytes + , parserRangeUtf8Bytes + , parserRangeUtf8BytesLenient -- * Types , IPv4(..) , IPv4# @@ -235,51 +239,71 @@ || mask12 .&. w == p20 || mask16 .&. w == p16 +---------------------------------------- +-- Note [The implementation of reserved] +---------------------------------------- +-- The @reserved@ function has been optimized to perform well in the +-- microbenchmark @CIDR Inclusion/reserved@. We perform an inital case +-- on the upper three bits (8 possible values), which GHC will compile +-- to a jump table. This helps because the reserved ranges of IPv4 +-- addresses are somewhat clustered. Notice that everything in +-- 32.0.0.0/3, 64.0.0.0/3, and 128.0.0.0/3 is publicly routable, and +-- everything in 224.0.0.0/3 is reserved. This means that for exactly +-- half of the IPv4 addresses that exist, this single jump is sufficient +-- for determining whether or not they are reserved. For the others, +-- there is a little more work to do, particularly in the 192.0.0.0/3 +-- range. On the laptop that ran the microbenchmark, this function +-- decided the reservedness of 100 random IPv4 addresses in 200ns. + -- | Checks to see if the 'IPv4' address belongs to a reserved -- network. This includes the three private networks that 'private' -- checks along with several other ranges that are not used --- on the public Internet. +-- on the public Internet. The implementation of this function +-- is optimized. reserved :: IPv4 -> Bool -reserved = - let a = getIPv4 $ fromOctets' 0 0 0 0 - b = getIPv4 $ fromOctets' 100 64 0 0 - c = getIPv4 $ fromOctets' 127 0 0 0 - d = getIPv4 $ fromOctets' 169 254 0 0 - e = getIPv4 $ fromOctets' 192 0 0 0 - f = getIPv4 $ fromOctets' 192 0 2 0 - g = getIPv4 $ fromOctets' 192 88 99 0 - h = getIPv4 $ fromOctets' 198 18 0 0 - i = getIPv4 $ fromOctets' 198 51 100 0 - j = getIPv4 $ fromOctets' 203 0 113 0 - k = getIPv4 $ fromOctets' 224 0 0 0 - l = getIPv4 $ fromOctets' 240 0 0 0 - m = getIPv4 $ fromOctets' 255 255 255 255 - in \(IPv4 w) -> mask8 .&. w == p24 - || mask12 .&. w == p20 - || mask16 .&. w == p16 - || mask8 .&. w == a - || mask10 .&. w == b - || mask8 .&. w == c - || mask16 .&. w == d - || mask24 .&. w == e - || mask24 .&. w == f - || mask24 .&. w == g - || mask15 .&. w == h - || mask24 .&. w == i - || mask24 .&. w == j - || mask4 .&. w == k - || mask4 .&. w == l - || mask32 .&. w == m +reserved !(IPv4 w) = case unsafeShiftR w 29 of + 0 -> + let a = getIPv4 $ fromOctets' 0 0 0 0 + y = getIPv4 $ fromOctets' 10 0 0 0 + in mask8 .&. w == a + || mask8 .&. w == y + 1 -> False + 2 -> False + 3 -> + let b = getIPv4 $ fromOctets' 100 64 0 0 + c = getIPv4 $ fromOctets' 127 0 0 0 + in mask8 .&. w == c + || mask10 .&. w == b + 4 -> False + 5 -> + let d = getIPv4 $ fromOctets' 169 254 0 0 + x = getIPv4 $ fromOctets' 172 16 0 0 + in mask12 .&. w == x + || mask16 .&. w == d + 6 -> + let e = getIPv4 $ fromOctets' 192 0 0 0 + f = getIPv4 $ fromOctets' 192 0 2 0 + g = getIPv4 $ fromOctets' 192 88 99 0 + h = getIPv4 $ fromOctets' 198 18 0 0 + i = getIPv4 $ fromOctets' 198 51 100 0 + j = getIPv4 $ fromOctets' 203 0 113 0 + z = getIPv4 $ fromOctets' 192 168 0 0 + in mask15 .&. w == h + || mask16 .&. w == z + || mask24 .&. w == e + || mask24 .&. w == f + || mask24 .&. w == g + || mask24 .&. w == i + || mask24 .&. w == j + _ -> True -mask8,mask4,mask12,mask16,mask10,mask24,mask32,mask15 :: Word32 -mask4 = 0xF0000000 +mask8,mask12,mask16,mask10,mask24,mask15 :: Word32 mask8 = 0xFF000000 mask10 = 0xFFC00000 mask12 = 0xFFF00000 mask15 = 0xFFFE0000 mask16 = 0xFFFF0000 mask24 = 0xFFFFFF00 -mask32 = 0xFFFFFFFF -- | Checks to see if the 'IPv4' address is publicly routable. -- @@ -447,6 +471,43 @@ Latin.char e '.' !d <- Latin.decWord8 e pure (getIPv4 (fromOctets a b c d)) + +-- | Parse UTF-8-encoded 'Bytes' into an 'IPv4Range'. +-- This requires the mask to be present. +-- +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8Bytes ()) (Bytes.fromAsciiString "192.168.0.0/16") +-- 192.168.0.0/16 +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8Bytes ()) (Bytes.fromAsciiString "10.10.10.1") +-- nope +-- +-- See 'parserRangeUtf8BytesLenient' for a variant that treats +-- a missing mask as a @/32@ mask. +parserRangeUtf8Bytes :: e -> Parser.Parser e s IPv4Range +parserRangeUtf8Bytes e = do + base <- parserUtf8Bytes e + Latin.char e '/' + theMask <- Latin.decWord8 e + if theMask > 32 + then Parser.fail e + else pure $! normalize (IPv4Range base theMask) + +-- | Variant of 'parserRangeUtf8Bytes' that allows the mask +-- to be omitted. An omitted mask is treated as a @/32@ mask. +-- +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8BytesLenient ()) (Bytes.fromAsciiString "192.168.0.0/16") +-- 192.168.0.0/16 +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8BytesLenient ()) (Bytes.fromAsciiString "10.10.10.1") +-- 10.10.10.1/32 +parserRangeUtf8BytesLenient :: e -> Parser.Parser e s IPv4Range +parserRangeUtf8BytesLenient e = do + base <- parserUtf8Bytes e + Latin.trySatisfy (=='/') >>= \case + True -> do + theMask <- Latin.decWord8 e + if theMask > 32 + then Parser.fail e + else pure $! normalize (IPv4Range base theMask) + False -> pure $! IPv4Range base 32 -- | Encode an 'IPv4' as a bytestring 'Builder.Builder' -- diff --git a/src/Net/IPv6.hs b/src/Net/IPv6.hs --- a/src/Net/IPv6.hs +++ b/src/Net/IPv6.hs @@ -56,6 +56,9 @@ , decodeRange , parserRange , printRange + -- ** UTF-8 Bytes + , parserRangeUtf8Bytes + , parserRangeUtf8BytesLenient -- * Types , IPv6(..) , IPv6Range(..) @@ -678,6 +681,7 @@ r <- pieceParserStep e w0 pure (Just r) +-- This should probably be moved into bytesmith and renamed. pieceParser :: e -> Parser.Parser e s Word16 pieceParser e = Latin.hexNibble e >>= pieceParserStep e @@ -696,6 +700,43 @@ else Latin.tryHexNibble >>= \case Nothing -> pure (fromIntegral acc) Just w -> pieceParserStep e (16 * acc + w) + +-- | Parse UTF-8-encoded 'Bytes' into an 'IPv4Range'. +-- This requires the mask to be present. +-- +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8Bytes ()) (Bytes.fromAsciiString "1b02:f001:5:200b::/80") +-- 1b02:f001:5:200b::/80 +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8Bytes ()) (Bytes.fromAsciiString "abcd::") +-- nope +-- +-- See 'parserRangeUtf8BytesLenient' for a variant that treats +-- a missing mask as a @/32@ mask. +parserRangeUtf8Bytes :: e -> Parser.Parser e s IPv6Range +parserRangeUtf8Bytes e = do + base <- parserUtf8Bytes e + Latin.char e '/' + theMask <- Latin.decWord8 e + if theMask > 128 + then Parser.fail e + else pure $! normalize (IPv6Range base theMask) + +-- | Variant of 'parserRangeUtf8Bytes' that allows the mask +-- to be omitted. An omitted mask is treated as a @/128@ mask. +-- +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8BytesLenient ()) (Bytes.fromAsciiString "1b02:f001:5:200b::/80") +-- 1b02:f001:5:200b::/80 +-- >>> maybe (putStrLn "nope") printRange $ Parser.parseBytesMaybe (parserRangeUtf8BytesLenient ()) (Bytes.fromAsciiString "abcd::") +-- abcd::/128 +parserRangeUtf8BytesLenient :: e -> Parser.Parser e s IPv6Range +parserRangeUtf8BytesLenient e = do + base <- parserUtf8Bytes e + Latin.trySatisfy (=='/') >>= \case + True -> do + theMask <- Latin.decWord8 e + if theMask > 128 + then Parser.fail e + else pure $! normalize (IPv6Range base theMask) + False -> pure $! IPv6Range base 128 -- | Parse an 'IPv6' using 'Atto.Parser'. -- diff --git a/src/Net/Mac.hs b/src/Net/Mac.hs --- a/src/Net/Mac.hs +++ b/src/Net/Mac.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -37,6 +39,10 @@ , parserWithUtf8 -- ** ByteString , decodeBytes + -- ** UTF-8 Bytes + , boundedBuilderUtf8 + , decodeUtf8Bytes + , parserUtf8Bytes -- ** Printing , print -- * Types @@ -71,11 +77,16 @@ import Text.ParserCombinators.ReadPrec (prec,step) import Text.Read (Read(..),Lexeme(Ident),lexP,parens) +import qualified Arithmetic.Nat as Nat import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.Attoparsec.ByteString as AB import qualified Data.Attoparsec.ByteString as ABW import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteArray.Builder.Bounded as BBB +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Parser as Parser +import qualified Data.Bytes.Parser.Latin as Latin import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Fixed as BFB @@ -121,19 +132,25 @@ , fromIntegral w ) +-- | This function is deprecated. It will be renamed in a future release +-- since the name is misleading. +decodeBytes :: ByteString -> Maybe Mac +{-# DEPRECATED decodeBytes "Prefer decodeOctets" #-} +decodeBytes = decodeOctets + -- | Decode a 'Mac' address from a 'ByteString'. Each byte is interpreted -- as an octet of the 'Mac' address. Consequently, 'ByteString's -- of length 6 successfully decode, and all other 'ByteString's fail -- to decode. -- --- >>> decodeBytes (B.pack [0x6B,0x47,0x18,0x90,0x55,0xC3]) +-- >>> decodeOctets (B.pack [0x6B,0x47,0x18,0x90,0x55,0xC3]) -- Just (mac 0x6b47189055c3) --- >>> decodeBytes (B.replicate 6 0x3A) +-- >>> decodeOctets (B.replicate 6 0x3A) -- Just (mac 0x3a3a3a3a3a3a) --- >>> decodeBytes (B.replicate 7 0x3A) +-- >>> decodeOctets (B.replicate 7 0x3A) -- Nothing -decodeBytes :: ByteString -> Maybe Mac -decodeBytes bs = if B.length bs == 6 +decodeOctets :: ByteString -> Maybe Mac +decodeOctets bs = if B.length bs == 6 then Just $ fromOctets (BU.unsafeIndex bs 0) (BU.unsafeIndex bs 1) @@ -398,6 +415,74 @@ decodeLenientUtf8 :: ByteString -> Maybe Mac decodeLenientUtf8 bs = rightToMaybe (AB.parseOnly (parserLenientUtf8 <* AB.endOfInput) bs) + +-- | Encode a 'Mac' address as colon-separated hexadecimal octets, +-- preferring lowercase for alphabetical characters. +-- +-- >>> BBB.run Nat.constant $ boundedBuilderUtf8 $ mac 0xDEADBEEF1609 +-- [0x64, 0x65, 0x3a, 0x61, 0x64, 0x3a, 0x62, 0x65, 0x3a, 0x65, 0x66, 0x3a, 0x31, 0x36, 0x3a, 0x30, 0x39] +boundedBuilderUtf8 :: Mac -> BBB.Builder 17 +boundedBuilderUtf8 !w = + BBB.word8PaddedLowerHex w0 + `BBB.append` + BBB.ascii ':' + `BBB.append` + BBB.word8PaddedLowerHex w1 + `BBB.append` + BBB.ascii ':' + `BBB.append` + BBB.word8PaddedLowerHex w2 + `BBB.append` + BBB.ascii ':' + `BBB.append` + BBB.word8PaddedLowerHex w3 + `BBB.append` + BBB.ascii ':' + `BBB.append` + BBB.word8PaddedLowerHex w4 + `BBB.append` + BBB.ascii ':' + `BBB.append` + BBB.word8PaddedLowerHex w5 + where + (w0,w1,w2,w3,w4,w5) = toOctets w + +-- | Lenient decoding of MAC address. This +-- is case insensitive and allows either @:@ or @-@ as the separator. +-- It also allows leading zeroes to be missing. +-- +-- >>> decodeUtf8Bytes (Bytes.fromAsciiString "A2:DE:AD:BE:EF:67") +-- Just (mac 0xa2deadbeef67) +-- >>> decodeUtf8Bytes (Bytes.fromAsciiString "13-a2-FE-A4-17-96") +-- Just (mac 0x13a2fea41796) +decodeUtf8Bytes :: Bytes.Bytes -> Maybe Mac +decodeUtf8Bytes = Parser.parseBytesMaybe (parserUtf8Bytes ()) + +-- | Leniently parse UTF-8-encoded 'Bytes' as a 'Mac' address. This +-- is case insensitive and allows either @:@ or @-@ as the separator. +-- It also allows leading zeroes to be missing. +-- +-- >>> Parser.parseBytes (parserUtf8Bytes ()) (Bytes.fromAsciiString "de:ad:BE:EF:1:23") +-- Success (Slice {offset = 16, length = 0, value = mac 0xdeadbeef0123}) +parserUtf8Bytes :: e -> Parser.Parser e s Mac +parserUtf8Bytes e = do + w1 <- Latin.hexWord8 e + Latin.any e >>= \case + ':' -> do + w2 <- Latin.hexWord8 e <* Latin.char e ':' + w3 <- Latin.hexWord8 e <* Latin.char e ':' + w4 <- Latin.hexWord8 e <* Latin.char e ':' + w5 <- Latin.hexWord8 e <* Latin.char e ':' + w6 <- Latin.hexWord8 e + pure (fromOctets w1 w2 w3 w4 w5 w6) + '-' -> do + w2 <- Latin.hexWord8 e <* Latin.char e '-' + w3 <- Latin.hexWord8 e <* Latin.char e '-' + w4 <- Latin.hexWord8 e <* Latin.char e '-' + w5 <- Latin.hexWord8 e <* Latin.char e '-' + w6 <- Latin.hexWord8 e + pure (fromOctets w1 w2 w3 w4 w5 w6) + _ -> Parser.fail e -- | Make a bytestring builder from a 'Mac' address -- using a colon as the separator. diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -3,6 +3,9 @@ import Criterion.Main import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..)) import Data.Maybe (fromJust) +import Data.Primitive (PrimArray,foldlPrimArray') +import Data.Bool (bool) +import System.Random (mkStdGen,randoms) import qualified Data.Bytes as Bytes import qualified Data.Text as Text import qualified Net.Mac as Mac @@ -15,6 +18,7 @@ import qualified IPv4ByteString1 import qualified IPv4DecodeText1 import qualified IPv4DecodeText2 +import qualified GHC.Exts as Exts -- import qualified IPv4TextVariableBuilder main :: IO () @@ -36,6 +40,7 @@ ip6Skip = fromJust $ IPv6.decode ip6TextSkip ip6TextHex = Text.pack "a:b::c:d" ip6Hex = fromJust $ IPv6.decode ip6TextHex + hundredAddrs = Exts.fromList (map IPv4 (take 100 (randoms (mkStdGen 42)))) :: PrimArray IPv4 defaultMain [ bgroup "Mac to Text" [ bench "Current Implementation, pairs" $ whnf Mac.encode mac @@ -95,4 +100,16 @@ , bench "a:b::c:d" $ whnf IPv6.encodeShort ip6Hex , bench "2001:db8:ba1:0:aaaa:542c:bb:cc00" $ whnf IPv6.encodeShort ip6Complicated ] + , bgroup "CIDR Inclusion" + [ bench "reserved" $ whnf manyReserved hundredAddrs + , bench "private" $ whnf manyPrivate hundredAddrs + ] ] + +manyReserved :: PrimArray IPv4 -> Int +{-# noinline manyReserved #-} +manyReserved x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.reserved addr) + acc) 0 x + +manyPrivate :: PrimArray IPv4 -> Int +{-# noinline manyPrivate #-} +manyPrivate x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.private addr) + acc) 0 x diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -118,6 +118,28 @@ , testProperty "Normalize does not affect membership" propNormalizeMember , testProperty "Membership agrees with bounds" propMemberUpperLower , testProperty "Range contains self" propRangeSelf + , testGroup "reserved" + [ PH.testCase "A" $ IPv4.reserved (IPv4.ipv4 0 1 2 3) @=? True + , PH.testCase "B" $ IPv4.reserved (IPv4.ipv4 1 0 0 0) @=? False + , PH.testCase "C" $ IPv4.reserved (IPv4.ipv4 100 64 0 3) @=? True + , PH.testCase "D" $ IPv4.reserved (IPv4.ipv4 127 255 255 255) @=? True + , PH.testCase "E" $ IPv4.reserved (IPv4.ipv4 110 0 0 255) @=? False + , PH.testCase "F" $ IPv4.reserved (IPv4.ipv4 192 0 2 255) @=? True + , PH.testCase "G" $ IPv4.reserved (IPv4.ipv4 203 0 113 0) @=? True + , PH.testCase "H" $ IPv4.reserved (IPv4.ipv4 225 0 0 0) @=? True + , PH.testCase "I" $ IPv4.reserved (IPv4.ipv4 226 0 0 0) @=? True + , PH.testCase "J" $ IPv4.reserved (IPv4.ipv4 255 255 255 254) @=? True + , PH.testCase "K" $ IPv4.reserved (IPv4.ipv4 255 255 255 255) @=? True + , PH.testCase "L" $ IPv4.reserved (IPv4.ipv4 224 0 0 0) @=? True + , PH.testCase "M" $ IPv4.reserved (IPv4.ipv4 239 255 255 255) @=? True + , PH.testCase "N" $ IPv4.reserved (IPv4.ipv4 223 255 255 255) @=? False + , PH.testCase "O" $ IPv4.reserved (IPv4.ipv4 203 0 114 0) @=? False + , PH.testCase "P" $ IPv4.reserved (IPv4.ipv4 203 0 112 255) @=? False + , PH.testCase "Q" $ IPv4.reserved (IPv4.ipv4 203 0 113 255) @=? True + , PH.testCase "R" $ IPv4.reserved (IPv4.ipv4 192 88 100 0) @=? False + , PH.testCase "S" $ IPv4.reserved (IPv4.ipv4 192 88 99 0) @=? True + , PH.testCase "T" $ IPv4.reserved (IPv4.ipv4 192 0 1 0) @=? False + ] ] , testGroup "IPv6 Range Operations" [ testProperty "Idempotence of normalizing IPv6 range"