ip 1.2.1 → 1.3.0
raw patch · 6 files changed
+242/−151 lines, 6 filesdep −semigroups
Dependencies removed: semigroups
Files
- ip.cabal +4/−7
- src/Net/IPv4/Range.hs +20/−0
- src/Net/IPv6.hs +169/−102
- src/Net/Mac.hs +15/−37
- test/Bench.hs +11/−0
- test/Test.hs +23/−5
ip.cabal view
@@ -1,5 +1,5 @@ name: ip-version: 1.2.1+version: 1.3.0 synopsis: Library for IP and MAC addresses homepage: https://github.com/andrewthad/haskell-ip#readme license: BSD3@@ -49,15 +49,12 @@ build-depends: base >= 4.9 && < 5 , attoparsec >= 0.13 && < 0.14- , aeson >= 0.9 && < 1.4- , hashable >= 1.2 && < 1.3+ , aeson >= 0.9 && < 1.5+ , hashable >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 , vector >= 0.11 && < 0.13 , primitive >= 0.6 && < 0.7- , semigroups >= 0.16 && < 0.19- -- if impl(ghcjs)- -- build-depends: ghcjs-base >= 0.2 && < 0.3 ghc-options: -Wall -O2 default-language: Haskell2010 @@ -93,7 +90,7 @@ base , ip , hspec- , hspec >= 2.4.4 && < 2.5+ , hspec >= 2.4.4 other-modules: Net.IPv4Spec Net.IPv4.RangeSpec
src/Net/IPv4/Range.hs view
@@ -9,6 +9,7 @@ module Net.IPv4.Range ( -- * Range functions range+ , fromBounds , normalize , contains , member@@ -72,6 +73,25 @@ -- sized and sets masked bits in the 'IPv4' to zero. range :: IPv4 -> Word8 -> IPv4Range range addr len = normalize (IPv4Range addr len)++-- | Given an inclusive lower and upper ip address, create the smallest+-- 'IPv4Range' that contains the two. This is helpful in situations where+-- input given as a range like @192.168.16.0-192.168.19.255@ needs to be+-- handled. This makes the range broader if it cannot be represented in+-- CIDR notation.+--+-- >>> print $ fromBounds (fromOctets 192 168 16 0) (fromOctets 192 168 19 255)+-- 192.168.16.0/22+-- >>> print $ fromBounds (fromOctets 10 0 5 7) (fromOctets 10 0 5 14)+-- 10.0.5.0/28+fromBounds :: IPv4 -> IPv4 -> IPv4Range+fromBounds (IPv4 a) (IPv4 b) =+ let lo = min a b+ hi = max a b+ in normalize (IPv4Range (IPv4 lo) (maskFromBounds lo hi))++maskFromBounds :: Word32 -> Word32 -> Word8+maskFromBounds lo hi = fromIntegral (Bits.countLeadingZeros (Bits.xor lo hi)) -- | Checks to see if an 'IPv4' address belongs in the 'IPv4Range'. --
src/Net/IPv6.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wall #-} @@ -26,21 +31,30 @@ , print ) where -import Prelude hiding (any, print)+import Net.IPv4 (IPv4(..))+import qualified Net.IPv4 as IPv4++import Control.Applicative+import Control.Monad.Primitive+import Control.Monad.ST import Data.Bits-import Data.List (intercalate, group)-import Data.Word import Data.Char (chr)-import Control.Applicative+import Data.List (intercalate, group)+import Data.Primitive.Addr+import Data.Primitive.ByteArray+import Data.Primitive.Types (Prim(..)) import Data.Text (Text)-import Text.Read (Read(..),Lexeme(Ident),lexP,parens)+import Data.Word+import GHC.Exts+import Numeric (showHex)+import Prelude hiding (any, print) import Text.ParserCombinators.ReadPrec (prec,step)-import qualified Data.Text as Text-import qualified Data.Text.IO as TIO-import qualified Data.Attoparsec.Text as Atto+import Text.Read (Read(..),Lexeme(Ident),lexP,parens) import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.Text as AT-import Numeric (showHex)+import qualified Data.Attoparsec.Text as Atto+import qualified Data.Text as Text+import qualified Data.Text.IO as TIO -- $setup --@@ -77,6 +91,61 @@ where (a,b,c,d,e,f,g,h) = toWord16s addr +instance Prim IPv6 where+ sizeOf# _ = 2# *# sizeOf# (undefined :: Word64)+ alignment# _ = alignment# (undefined :: Word64)+ indexByteArray# arr# i# =+ let i = I# i#+ arr = ByteArray arr#+ in IPv6 (indexByteArray arr (2 * i + 0)) (indexByteArray arr (2 * i + 1))+ readByteArray# :: forall s. () => MutableByteArray# s -> Int# -> State# s -> (# State# s, IPv6 #)+ readByteArray# arr# i# = internal $ do+ let i = I# i#+ arr = MutableByteArray arr#+ a <- readByteArray arr (2 * i + 0) :: ST s Word64+ b <- readByteArray arr (2 * i + 1)+ return (IPv6 a b)+ writeByteArray# :: forall s. () => MutableByteArray# s -> Int# -> IPv6 -> State# s -> State# s+ writeByteArray# arr# i# (IPv6 a b) = internal_ $ do+ let i = I# i#+ arr = MutableByteArray arr#+ writeByteArray arr (2 * i + 0) a+ writeByteArray arr (2 * i + 1) b :: ST s ()+ setByteArray# arr# i# len# ident = go 0#+ where+ go ix# s0 = if isTrue# (ix# <# len#)+ then case writeByteArray# arr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0+ indexOffAddr# :: Addr# -> Int# -> IPv6+ indexOffAddr# addr# i# =+ let i = I# i#+ addr = Addr addr#+ in IPv6 (indexOffAddr addr (2 * i + 0)) (indexOffAddr addr (2 * i + 1))+ readOffAddr# :: forall s. () => Addr# -> Int# -> State# s -> (# State# s, IPv6 #)+ readOffAddr# addr# i# = internal $ do+ let i = I# i#+ addr = Addr addr#+ a <- readOffAddr addr (2 * i + 0) :: ST s Word64+ b <- readOffAddr addr (2 * i + 1)+ return (IPv6 a b)+ writeOffAddr# :: forall s. () => Addr# -> Int# -> IPv6 -> State# s -> State# s+ writeOffAddr# addr# i# (IPv6 a b) = internal_ $ do+ let i = I# i#+ addr = Addr addr#+ writeOffAddr addr (2 * i + 0) a+ writeOffAddr addr (2 * i + 1) b :: ST s ()+ setOffAddr# addr# i# len# ident = go 0#+ where+ go ix# s0 = if isTrue# (ix# <# len#)+ then case writeOffAddr# addr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0++internal_ :: PrimBase m => m () -> State# (PrimState m) -> State# (PrimState m)+internal_ m s = case internal m s of+ (# s', _ #) -> s'+ print :: IPv6 -> IO () print = TIO.putStrLn . encode @@ -206,9 +275,23 @@ -- | Encodes the IP, using zero-compression on the leftmost-longest string of -- zeroes in the address.+-- Per <https://tools.ietf.org/html/rfc5952#section-5 RFC 5952 Section 5>,+-- this uses mixed notation when encoding an IPv4-mapped IPv6 address:+--+-- >>> T.putStrLn $ encode $ fromWord16s 0xDEAD 0xBEEF 0x0 0x0 0x0 0x0 0x0 0x1234+-- dead:beef::1234+-- >>> T.putStrLn $ encode $ fromWord16s 0x0 0x0 0x0 0x0 0x0 0xFFFF 0x6437 0xA5B4+-- ::ffff:100.55.165.180+-- >>> T.putStrLn $ encode $ fromWord16s 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0x0+-- :: encode :: IPv6 -> Text-encode ip = toText [w1, w2, w3, w4, w5, w6, w7, w8]+encode ip =+ if isIPv4MappedAddress+ -- This representation is RECOMMENDED by https://tools.ietf.org/html/rfc5952#section-5+ then Text.pack "::ffff:" `mappend` IPv4.encode (IPv4.IPv4 (fromIntegral w7 `unsafeShiftL` 16 .|. fromIntegral w8))+ else toText [w1, w2, w3, w4, w5, w6, w7, w8] where+ isIPv4MappedAddress = w1 == 0 && w2 == 0 && w3 == 0 && w4 == 0 && w5 == 0 && w6 == 0xFFFF (w1, w2, w3, w4, w5, w6, w7, w8) = toWord16s ip toText ws = Text.pack $ intercalate ":" $ expand 0 longestZ grouped where@@ -226,106 +309,90 @@ longestZ = maximum . (0:) . map snd . filter ((==0) . fst) $ grouped grouped = map (\x -> (head x, length x)) (group ws) +-- | Decode an IPv6 address. This accepts both standard IPv6+-- notation (with zero compression) and mixed notation for+-- IPv4-mapped IPv6 addresses. decode :: Text -> Maybe IPv6 decode t = rightToMaybe (AT.parseOnly (parser <* AT.endOfInput) t) parser :: Atto.Parser IPv6-parser = do- s <- start- case toIPv6 s of- Nothing -> fail "Wrong number of octets in IPv6 address"- Just ip -> return ip- where- msg = "All chunks in a formatted IPv6 address must be between 0x0000 and 0xFFFF"- colonMsg = "Cannot use double colon for omitting zeroes more than once in an IPv6 address"- start = do- c <- Atto.peekChar'- if c == ':'- then go (-1) 0 []- else Atto.hexadecimal >>= \w -> go (-1) 1 [w]- -- r <- fmap Just Atto.hexadecimal <|> (Nothing <$ Atto.char ':')- -- case r of- -- Just !w -> go (-1) 1 [w]- -- Nothing -> go 0 0 []- go !colonIndex !currentIndex !ws = do- r <- do- m <- Atto.peekChar- case m of- Nothing -> return ResDone- Just c -> if c == ':'- then do- _ <- Atto.anyChar -- should be a colon- if colonIndex == currentIndex- then fmap ResWord Atto.hexadecimal <|> pure ResDone- else do- d <- Atto.peekChar'- if d == ':'- then return ResColon- else fmap ResWord Atto.hexadecimal- else return ResDone- case r of- ResDone -> pure (S colonIndex currentIndex ws)- ResColon -> if alreadySet colonIndex- then fail colonMsg- else go currentIndex currentIndex ws- ResWord w -> restrictTo16 msg w >> go colonIndex (currentIndex + 1) (w : ws)--toIPv6 :: S -> Maybe IPv6-toIPv6 (S colonIndex total input) = case compare total 8 of- EQ -> if colonIndex == (-1)- then go 0 0 input- else Nothing- GT -> Nothing- LT -> go 0 0 input+parser = startIP >>= makeIP where- revColonIndex = total - colonIndex- spacesToSkip = 8 - total- go :: Int -> Word64 -> [Word64] -> Maybe IPv6- go !ix !acc ws = if ix > 3- then fmap (flip IPv6 acc) (go2 ix 0 ws)- else case ws of- w : wsNext -> if ix == revColonIndex- then go (ix + spacesToSkip) acc (w : wsNext)- else go (ix + 1) (acc .|. unsafeShiftL w (times16 ix)) wsNext- [] -> if ix == revColonIndex- then Just $ IPv6 0 acc- else Nothing -- Not enough word16s in list- go2 :: Int -> Word64 -> [Word64] -> Maybe Word64- go2 !ix !acc ws = case ws of- w : wsNext -> if ix == revColonIndex- then go2 (ix + spacesToSkip) acc (w : wsNext)- else go2 (ix + 1) (acc .|. unsafeShiftL w (times16 ix - 64)) wsNext- [] -> if ix == revColonIndex || ix > 7- then Just acc- else Nothing -- Not enough word16s in list--times16 :: Int -> Int-times16 a = unsafeShiftL a 4+ -- handles the case where an IP starts with ::+ startIP :: Atto.Parser ([Word16], Maybe [Word16])+ startIP = + (\ends -> ([], Just ends)) <$> (Atto.char ':' *> Atto.char ':' *> restOfIP []) <|>+ fullIP [] -alreadySet :: Int -> Bool-alreadySet i = i /= (-1)+ -- a full IP that might contain ::+ fullIP :: [Word16] -> Atto.Parser ([Word16], Maybe [Word16])+ fullIP starts =+ ((\x -> (x ++ starts, Nothing)) <$> ipv4) <|>+ startPart starts -restrictTo16 :: String -> Word64 -> Atto.Parser ()-restrictTo16 msg w = if w > 65535- then fail msg- else return ()+ -- an IP that cannot contain ::+ restOfIP :: [Word16] -> Atto.Parser [Word16]+ restOfIP ends =+ ((\x -> x ++ ends) <$> ipv4) <|>+ endPart ends <|>+ pure ends+ + ipv4 = ipv4ToWord16s <$> IPv4.parser+ ipv4ToWord16s (IPv4 ip) = [fromIntegral (ip .&. 0xFFFF), fromIntegral (ip `unsafeShiftR` 16)]+ + -- a colon-separated part before ::+ startPart (starts) = do+ part <- Atto.hexadecimal+ let result = (part : starts)+ Atto.peekChar >>= \case + Just ':' -> do+ _ <- Atto.anyChar -- will be ':'+ Atto.peekChar >>= \case+ Just ':' -> do+ _ <- Atto.anyChar -- will be ':' + (\ends -> (result, Just ends)) <$> restOfIP []+ _ ->+ fullIP result+ _ ->+ pure (result, Nothing) --- | This is an internal data type used as the result--- after parsing an ipv6 address. The first field--- indicates the index at which a double colon occurs.--- The second is the length of the third.--- The third is a reversed list of the 16s--- that comprise the ipv6 address.-data S = S- { _sDoubleColon :: {-# UNPACK #-} !Int- , _sTotal :: {-# UNPACK #-} !Int- , _sRevWords :: ![Word64]- } deriving (Show,Read)+ -- a colon-separated part after ::+ endPart ends = do+ part <- Atto.hexadecimal+ let result = part : ends+ Atto.peekChar >>= \case + Just ':' -> do+ _ <- Atto.anyChar -- will be ':'+ Atto.peekChar >>= \case+ Just ':' -> do+ fail "Cannot use double colon for omitting zeroes more than once in an IPv6 address"+ _ ->+ restOfIP result+ _ ->+ pure result -data Res- = ResWord {-# UNPACK #-} !Word64- | ResColon- | ResDone+ makeIP :: ([Word16], Maybe [Word16]) -> Atto.Parser IPv6+ makeIP (starts, mends) =+ case mends of + -- Nothing indicates we never encountered double-colon, so we must have+ -- all 8 parts:+ Nothing -> do+ if numStarts /= 8+ then fail "not enough colon-separated parts in IPv6 address"+ else+ let [w1, w2, w3, w4, w5, w6, w7, w8] = reverse starts in+ pure (fromWord16s w1 w2 w3 w4 w5 w6 w7 w8)+ -- otherwise, we did encounter a double-colon, so we expand it to fill:+ Just ends ->+ let numEnds = length ends in+ case compare (numStarts + numEnds) 8 of+ GT -> fail "too many colon-separated parts in IPv6 address"+ EQ -> fail "unnecessary double-colon in IPv6 address"+ LT -> + let [w1, w2, w3, w4, w5, w6, w7, w8] = reverse starts ++ replicate (8 - (numStarts + numEnds)) 0 ++ reverse ends in+ pure (fromWord16s w1 w2 w3 w4 w5 w6 w7 w8)+ where+ numStarts = length starts fromOctetsV6 :: Word64 -> Word64 -> Word64 -> Word64
src/Net/Mac.hs view
@@ -56,14 +56,10 @@ import GHC.Generics (Generic) import Data.Char (ord,chr) import Data.Primitive.Types (Prim(..))+import GHC.Exts import Text.Read (Read(..),Lexeme(Ident),lexP,parens) import Text.ParserCombinators.ReadPrec (prec,step) import GHC.Word (Word16(W16#))-import GHC.Int (Int(I#))-import Data.Primitive.Addr (Addr(..),writeOffAddr)-import Data.Primitive.ByteArray (MutableByteArray(..),writeByteArray)-import Control.Monad.Primitive (PrimState,PrimBase,internal)-import Control.Monad.ST (ST) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU import qualified Data.ByteString.Builder as BB@@ -77,9 +73,6 @@ import qualified Data.Aeson.Types as Aeson import qualified Data.Text.IO as TIO -import GHC.Exts (Word#,Int#,State#,MutableByteArray#,Addr#,(*#),(+#),indexWord16Array#,readWord16Array#,- indexWord16OffAddr#,readWord16OffAddr#,writeWord16Array#,writeWord16OffAddr#)- #if MIN_VERSION_aeson(1,0,0) import Data.Aeson (ToJSONKey(..),FromJSONKey(..), ToJSONKeyFunction(..),FromJSONKeyFunction(..))@@ -592,9 +585,20 @@ s1 -> case writeWord16OffAddr# arr (i +# 1#) (macToWord16B# m) s1 of s2 -> writeWord16OffAddr# arr (i +# 2#) (macToWord16C# m) s2 where !i = 3# *# i0- setByteArray# = defaultSetByteArray#- setOffAddr# = defaultSetOffAddr#- + setByteArray# arr# i# len# ident = go 0#+ where+ go ix# s0 = if isTrue# (ix# <# len#)+ then case writeByteArray# arr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0+ setOffAddr# addr# i# len# ident = go 0#+ where+ go ix# s0 = if isTrue# (ix# <# len#)+ then case writeOffAddr# addr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0++ macToWord16A# :: Mac -> Word# macToWord16A# (Mac w) = case word64ToWord16 (unsafeShiftR w 32) of W16# x -> x@@ -618,32 +622,6 @@ word64ToWord16 :: Word64 -> Word16 word64ToWord16 = fromIntegral--defaultSetByteArray# :: forall s a. Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s-defaultSetByteArray# arr# i# len# ident = internal_ (go 0)- where- !len = I# len#- !i = I# i#- !arr = MutableByteArray arr#- go :: Int -> ST s ()- go !ix = if ix < len- then writeByteArray arr (i + ix) ident >> go (i + 1)- else return ()--defaultSetOffAddr# :: forall s a. Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s-defaultSetOffAddr# addr# i# len# ident = internal_ (go 0)- where- !len = I# len#- !i = I# i#- !addr = Addr addr#- go :: Int -> ST s ()- go !ix = if ix < len- then writeOffAddr addr (i + ix) ident >> go (i + 1)- else return ()--internal_ :: PrimBase m => m () -> State# (PrimState m) -> State# (PrimState m)-internal_ m s = case internal m s of- (# s', () #) -> s' -- What this instance does is to display the -- inner contents in hexadecimal and pad them out to
test/Bench.hs view
@@ -5,6 +5,7 @@ import qualified Data.Text as Text import qualified Net.Mac as Mac import qualified Net.IPv4 as IPv4+import qualified Net.IPv6 as IPv6 import qualified Naive import qualified IPv4Text1@@ -19,6 +20,10 @@ let ipAddr = IPv4 1000000009 ipText = Text.pack "192.168.5.99" mac = Mac.fromOctets 0xFA 0xBB 0x43 0xA1 0x22 0x09+ ip6Text = Text.pack "::"+ ip6TextBigger = Text.pack "1:2:3:4:5:6:7:8"+ ip6TextSkip = Text.pack "1:2::7:8"+ ip6TextHex = Text.pack "a:b::c:d" defaultMain [ bgroup "Mac to Text" [ bench "Current Implementation, pairs" $ whnf Mac.encode mac@@ -49,5 +54,11 @@ [ bench "Naive" $ whnf Naive.encodeByteString ipAddr , bench "Preallocated: No Lookup Tables" $ whnf IPv4ByteString1.encode ipAddr , bench "Preallocated" $ whnf IPv4.encodeUtf8 ipAddr+ ]+ , bgroup "IPv6 from Text"+ [ bench "New '::'" $ whnf IPv6.decode ip6Text+ , bench "New '1:2:3:4:5:6:7:8'" $ whnf IPv6.decode ip6TextBigger+ , bench "New '1:2::7:8'" $ whnf IPv6.decode ip6TextSkip+ , bench "New 'a:b::c:d'" $ whnf IPv6.decode ip6TextHex ] ]
test/Test.hs view
@@ -10,7 +10,7 @@ import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary(..),Property,oneof,Gen,elements,choose)-import Test.HUnit (Assertion,(@?=))+import Test.HUnit (Assertion,(@?=),(@=?)) import Numeric (showHex) import Test.QuickCheck.Property (failed,succeeded,Result(..)) import Data.Bifunctor@@ -109,6 +109,7 @@ , testGroup "IPv6" [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6)) , lawsToTest (showReadLaws (Proxy :: Proxy IPv6))+ , lawsToTest (primLaws (Proxy :: Proxy IPv6)) ] , testGroup "IP" [ lawsToTest (jsonLaws (Proxy :: Proxy IP))@@ -171,7 +172,7 @@ where go a b c d e f str = Just (HexMac (Mac.fromOctets a b c d e f))- @?= fmap HexMac (Mac.decodeUtf8 (BC8.pack str))+ @=? fmap HexMac (Mac.decodeUtf8 (BC8.pack str)) testIPv4Parser :: Assertion testIPv4Parser = do@@ -180,7 +181,7 @@ where go a b c d str = Right (IPv4.fromOctets a b c d)- @?= (AB.parseOnly+ @=? (AB.parseOnly (IPv4.parserUtf8 <* AT.endOfInput) (BC8.pack str) )@@ -209,7 +210,7 @@ where go a b c d e f g h str = Right (HexIPv6 (IPv6.fromWord16s a b c d e f g h))- @?= fmap HexIPv6+ @=? fmap HexIPv6 (AT.parseOnly (IPv6.parser <* AT.endOfInput) (Text.pack str)@@ -220,10 +221,18 @@ go "1111:2222:3333:4444:5555:6666::7777:8888" go "1111:2222:3333:4444:5555:6666:7777:8888:9999" go "1111:2222:3333:4444:5555:6666:7777:8888::9999"++ go "1:127.0.0.1" -- not enough+ go "1:2:3:127.0.0.1"+ go "1:2:3:4:127.0.0.1"+ go "1:2:3:4:5:127.0.0.1"++ go "1:2:3:4:5:6:7:127.0.0.1" -- too much+ go "1:2:3:4:5:6:7:8:127.0.0.1" where go str = Left ()- @?= bimap (\_ -> ()) HexIPv6+ @=? bimap (\_ -> ()) HexIPv6 (AT.parseOnly (IPv6.parser <* AT.endOfInput) (Text.pack str)@@ -258,6 +267,15 @@ -- works with only first or last: "::2:3:4:5:6:7:8" `roundTripsTo` "::2:3:4:5:6:7:8" "1:2:3:4:5:6:7::" `roundTripsTo` "1:2:3:4:5:6:7::"++ -- decimal notation in IPv6 addresses:+ "1:2:3:4:5:6:0.7.0.8" `roundTripsTo` "1:2:3:4:5:6:7:8"+ "::0.0.0.0" `roundTripsTo` "::"++ -- per https://tools.ietf.org/html/rfc5952#section-5+ "::ffff:0:0" `roundTripsTo` "::ffff:0.0.0.0"+ "::ffff:00ff:ff00" `roundTripsTo` "::ffff:0.255.255.0"+ "::ffff:203.0.113.17" `roundTripsTo` "::ffff:203.0.113.17" where roundTripsTo s sExpected =