diff --git a/ip.cabal b/ip.cabal --- a/ip.cabal +++ b/ip.cabal @@ -1,5 +1,5 @@ name: ip -version: 0.5 +version: 0.6.0 synopsis: Library for IP and MAC addresses description: Please see README.md homepage: https://github.com/andrewthad/ip#readme @@ -44,6 +44,11 @@ , QuickCheck , text , bytestring + other-modules: + Naive + IPv4Text1 + IPv4Text2 + IPv4ByteString1 ghc-options: -Wall -O2 default-language: Haskell2010 @@ -59,6 +64,7 @@ Naive IPv4Text1 IPv4Text2 + IPv4ByteString1 ghc-options: -Wall -O2 default-language: Haskell2010 hs-source-dirs: test diff --git a/src/Net/IPv4/ByteString/Char8.hs b/src/Net/IPv4/ByteString/Char8.hs --- a/src/Net/IPv4/ByteString/Char8.hs +++ b/src/Net/IPv4/ByteString/Char8.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module Net.IPv4.ByteString.Char8 ( encode , decode @@ -12,15 +13,87 @@ import qualified Data.ByteString.Builder as Builder import Net.Internal (rightToMaybe) import Data.Text.Encoding (encodeUtf8, decodeUtf8') -import Data.ByteString (ByteString) +import Data.ByteString (ByteString,replicate) import Data.Attoparsec.ByteString.Char8 (Parser) import Data.ByteString.Builder (Builder) +import Data.ByteString.Char8 as BC8 --- | This should be rewritten to not create 'Text' as an +import Data.ByteString.Internal as I +import Data.Bits +import Foreign.Ptr +import Foreign.Storable +import Data.Word +import Data.ByteString.Unsafe as BSU +import Data.Monoid + +-- | This should be rewritten to not create 'Text' as an -- intermediate step. encode :: IPv4 -> ByteString -encode = encodeUtf8 . IPv4Text.encode +encode = toBSPreAllocated +toBSPreAllocated :: IPv4 -> ByteString +toBSPreAllocated (IPv4 !w) = I.unsafeCreateUptoN 15 (\ptr1 -> + do len1 <- writeWord ptr1 w1 + let ptr2 = ptr1 `plusPtr` len1 + poke ptr2 dot + len2 <- writeWord (ptr2 `plusPtr` 1) w2 + let ptr3 = ptr2 `plusPtr` len2 `plusPtr` 1 + poke ptr3 dot + len3 <- writeWord (ptr3 `plusPtr` 1) w3 + let ptr4 = ptr3 `plusPtr` len3 `plusPtr` 1 + poke ptr4 dot + len4 <- writeWord (ptr4 `plusPtr` 1) w4 + return (3 + len1 + len2 + len3 + len4)) + where w1 = fromIntegral $ shiftR w 24 + w2 = fromIntegral $ shiftR w 16 + w3 = fromIntegral $ shiftR w 8 + w4 = fromIntegral w + dot = 46 :: Word8 + writeWord :: Ptr Word8 -> Word8 -> IO Int + writeWord !ptr !word + | word >= 100 = do + let int = fromIntegral word + indx = int + int + int + get3 = fromIntegral . BSU.unsafeIndex threeDigits + poke ptr (get3 indx) + poke (ptr `plusPtr` 1) (get3 (indx + 1)) + poke (ptr `plusPtr` 2) (get3 (indx + 2)) + return 3 + | word >= 10 = do + let int = fromIntegral word + indx = int + int + get2 = fromIntegral . BSU.unsafeIndex twoDigits + poke ptr (get2 indx) + poke (ptr `plusPtr` 1) (get2 (indx + 1)) + return 2 + | otherwise = do + poke ptr (word + 48) + return 1 + +twoDigits :: ByteString +twoDigits = BC8.pack + "0001020304050607080910111213141516171819\ + \2021222324252627282930313233343536373839\ + \4041424344454647484950515253545556575859\ + \6061626364656667686970717273747576777879\ + \8081828384858687888990919293949596979899" + +threeDigits :: ByteString +threeDigits = + Data.ByteString.replicate 300 0 <> BC8.pack + "100101102103104105106107108109110111112\ + \113114115116117118119120121122123124125\ + \126127128129130131132133134135136137138\ + \139140141142143144145146147148149150151\ + \152153154155156157158159160161162163164\ + \165166167168169170171172173174175176177\ + \178179180181182183184185186187188189190\ + \191192193194195196197198199200201202203\ + \204205206207208209210211212213214215216\ + \217218219220221222223224225226227228229\ + \230231232233234235236237238239240241242\ + \243244245246247248249250251252253254255" + -- | This should also be rewritten decode :: ByteString -> Maybe IPv4 decode = IPv4Text.decode <=< rightToMaybe . decodeUtf8' @@ -38,8 +111,7 @@ <* AB.char '.' <*> (AB.decimal >>= limitSize) where - limitSize i = - if i > 255 + limitSize i = + if i > 255 then fail "All octets in an ip address must be between 0 and 255" else return i - diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -20,7 +20,10 @@ import qualified Naive import qualified IPv4Text1 import qualified IPv4Text2 +import qualified IPv4ByteString1 +import qualified Net.IPv4.ByteString.Char8 as NIPBS + main :: IO () main = do let ipAddr = IPv4 1000000009 @@ -32,5 +35,7 @@ ] , bgroup "IPv4 to ByteString" [ bench "Naive" $ whnf Naive.encodeByteString ipAddr + , bench "Preallocated: No Lookup Tables" $ whnf IPv4ByteString1.encode ipAddr + , bench "Preallocated" $ whnf NIPBS.encode ipAddr ] ] diff --git a/test/IPv4ByteString1.hs b/test/IPv4ByteString1.hs new file mode 100644 --- /dev/null +++ b/test/IPv4ByteString1.hs @@ -0,0 +1,43 @@ +module IPv4ByteString1 where + +import Net.IPv4 + +import Data.ByteString.Internal as I +import Data.Bits +import Foreign.Ptr +import Foreign.Storable +import Data.Word + +encode :: IPv4 -> ByteString +encode (IPv4 w) = I.unsafeCreateUptoN 15 (\ptr1 -> + do (len1,ptr2) <- writeWord ptr1 w1 + poke ptr2 dot + (len2,ptr3) <- writeWord (ptr2 `plusPtr` 1) w2 + poke ptr3 dot + (len3,ptr4) <- writeWord (ptr3 `plusPtr` 1) w3 + poke ptr4 dot + (len4,_) <- writeWord (ptr4 `plusPtr` 1) w4 + return (3 + len1 + len2 + len3 + len4)) + where w1 = fromIntegral $ shiftR w 24 + w2 = fromIntegral $ shiftR w 16 + w3 = fromIntegral $ shiftR w 8 + w4 = fromIntegral w + dot = 46 + writeWord :: Ptr Word8 -> Word8 -> IO (Int,Ptr Word8) + writeWord ptr word + | word >= 100 = do + let (word1,char3) = word `quotRem` 10 + (char1,char2) = word1 `quotRem` 10 + poke ptr (char1 + 48) + poke (ptr `plusPtr` 1) (char2 + 48) + poke (ptr `plusPtr` 2) (char3 + 48) + return (3,ptr `plusPtr` 3) + | word >= 10 = do + let (char1,char2) = word `quotRem` 10 + poke ptr (char1 + 48) + poke (ptr `plusPtr` 1) (char2 + 48) + return (2,ptr `plusPtr` 2) + | otherwise = do + poke ptr (word + 48) + return (1,ptr `plusPtr` 1) + diff --git a/test/Naive.hs b/test/Naive.hs --- a/test/Naive.hs +++ b/test/Naive.hs @@ -36,8 +36,8 @@ ] where (a,b,c,d) = IPv4.toOctets i -ipv4FromTextNaive :: Text -> Maybe IPv4 -ipv4FromTextNaive t = +decodeText :: Text -> Maybe IPv4 +decodeText t = case mapM (readMaybe . Text.unpack) (Text.splitOn (Text.pack ".") t) of Just [a,b,c,d] -> Just (IPv4.fromOctets a b c d) _ -> Nothing diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -13,9 +13,15 @@ import Net.Mac (Mac(..)) import qualified Net.IPv4 as IPv4 import qualified Net.IPv4.Text as IPv4_Text +import qualified Net.IPv4.ByteString.Char8 as IPv4_ByteString import qualified Net.Mac as Mac import qualified Net.Mac.Text as Mac_Text +import qualified Naive +import qualified IPv4Text1 +import qualified IPv4Text2 +import qualified IPv4ByteString1 + main :: IO () main = defaultMain tests @@ -23,17 +29,25 @@ tests = [ testGroup "Naive IPv4 encode/decode" [ testProperty "Isomorphism" - $ propEncodeDecodeIso ipv4ToTextNaive ipv4FromTextNaive + $ propEncodeDecodeIso Naive.encodeText Naive.decodeText ] , testGroup "Text Builder IPv4 Text encode/decode" [ testProperty "Identical to Naive" - $ propMatching toDotDecimalText ipv4ToTextNaive + $ propMatching IPv4Text2.encode Naive.encodeText ] , testGroup "Raw byte array IPv4 Text encode/decode" [ testProperty "Identical to Naive" - $ propMatching toTextPreAllocated ipv4ToTextNaive + $ propMatching IPv4Text1.encode Naive.encodeText ] - , testGroup "Performant MAC Text encode/decode" + , testGroup "Raw byte array (without lookup table) IPv4 ByteString encode/decode" + [ testProperty "Identical to Naive" + $ propMatching IPv4ByteString1.encode Naive.encodeByteString + ] + , testGroup "Raw byte array (with lookup table) IPv4 ByteString encode/decode" + [ testProperty "Identical to Naive" + $ propMatching IPv4_ByteString.encode Naive.encodeByteString + ] + , testGroup "Raw byte array MAC Text encode/decode" [ testProperty "Isomorphism" $ propEncodeDecodeIso Mac_Text.encode Mac_Text.decode ]