ip 1.3.0 → 1.4.0
raw patch · 7 files changed
+801/−614 lines, 7 filesdep ~aesondep ~basedep ~quickcheck-classes
Dependency ranges changed: aeson, base, quickcheck-classes
Files
- ip.cabal +4/−5
- src/Net/IPv4.hs +438/−39
- src/Net/IPv4/Range.hs +0/−443
- src/Net/IPv6.hs +243/−76
- src/Net/Types.hs +3/−3
- test/Doctests.hs +0/−1
- test/Test.hs +113/−47
ip.cabal view
@@ -1,5 +1,5 @@ name: ip-version: 1.3.0+version: 1.4.0 synopsis: Library for IP and MAC addresses homepage: https://github.com/andrewthad/haskell-ip#readme license: BSD3@@ -36,7 +36,6 @@ exposed-modules: Net.Mac Net.IPv4- Net.IPv4.Range Net.IPv6 Net.IP Net.Types@@ -47,9 +46,9 @@ Data.Text.Builder.Common.Internal Data.ByteString.Builder.Fixed build-depends:- base >= 4.9 && < 5+ base >= 4.9.1.0 && < 5 , attoparsec >= 0.13 && < 0.14- , aeson >= 0.9 && < 1.5+ , aeson >= 1.0 && < 1.5 , hashable >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11@@ -68,7 +67,7 @@ , test-framework , test-framework-quickcheck2 , QuickCheck- , quickcheck-classes >= 0.3 && < 0.5+ , quickcheck-classes >= 0.4.13 && < 0.5 , text , bytestring , HUnit
src/Net/IPv4.hs view
@@ -13,7 +13,7 @@ This module provides the IPv4 data type and functions for working with it. There are also encoding and decoding functions provided in this module, but they should be imported from- @Net.IPv4.Text@ and @Net.IPv4.ByteString.Char8@ instead. They are+ @Net.IPv4.Text@ and @Net.ByteString.Char8@ instead. They are defined here so that the 'FromJSON' and 'ToJSON' instances can use them. @@ -54,58 +54,78 @@ , decodeString -- ** Printing , print+ -- * IPv4 Ranges+ -- ** Range functions+ , range+ , fromBounds+ , normalize+ , contains+ , member+ , lowerInclusive+ , upperInclusive+ -- ** Conversion to IPv4+ , toList+ , toGenerator+ -- ** Private Ranges+ , private24+ , private20+ , private16+ -- ** Textual Conversion+ -- *** Text+ , encodeRange+ , decodeRange+ , builderRange+ , parserRange+ , printRange -- * Types , IPv4(..)+ , IPv4Range(..) -- * Interoperability -- $interoperability ) where -import Prelude hiding (any, print)-import Data.Bits ((.&.),(.|.),shiftR,shiftL,unsafeShiftR)-import Data.Word-import Data.Hashable-import Data.Aeson (FromJSON(..),ToJSON(..))-import GHC.Generics (Generic) import Control.Monad-import Data.Text.Internal (Text(..))+import Control.Monad.ST (ST,runST)+import Data.Aeson (FromJSON(..),ToJSON(..))+import Data.Aeson (ToJSONKey(..),FromJSONKey(..),ToJSONKeyFunction(..),FromJSONKeyFunction(..))+import Data.Bits ((.&.),(.|.),shiftR,shiftL,unsafeShiftR,complement,shift) import Data.ByteString (ByteString)-import Data.Vector.Generic.Mutable (MVector(..))-import Foreign.Ptr (Ptr,plusPtr)-import Foreign.Storable (poke)+import Data.Hashable import Data.Monoid ((<>))-import Data.Text.Encoding (decodeUtf8')-import Foreign.Storable (Storable) import Data.Primitive.Types (Prim)-import Control.Monad.ST (ST,runST)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Text.Internal (Text(..))+import Data.Vector.Generic.Mutable (MVector(..))+import Data.Word+import Foreign.Ptr (Ptr,plusPtr)+import Foreign.Storable (Storable, poke)+import GHC.Generics (Generic)+import Prelude hiding (any, print, print)+import Text.ParserCombinators.ReadPrec (prec,step) import Text.Printf (printf) import Text.Read (Read(..),Lexeme(Ident),lexP,parens)-import Text.ParserCombinators.ReadPrec (prec,step)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.Attoparsec.ByteString.Char8 as AB+import qualified Data.Attoparsec.Text as AT import qualified Data.Bits as Bits-import qualified Data.Text.Read as TextRead import qualified Data.ByteString.Builder as Builder-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Read as Text (Reader)-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Attoparsec.Text as AT-import qualified Data.Attoparsec.ByteString.Char8 as AB import qualified Data.ByteString.Char8 as BC8-import qualified Data.Text as Text import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as BSU+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.Text as Text+import qualified Data.Text.Array as TArray+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Builder as TBuilder+import qualified Data.Text.Lazy.Builder.Int as TBI+import qualified Data.Text.Read as TextRead import qualified Data.Vector.Generic as GVector import qualified Data.Vector.Generic.Mutable as MGVector-import qualified Data.Vector.Unboxed as UVector import qualified Data.Vector.Primitive as PVector-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson-import qualified Data.ByteString.Builder as BB-import qualified Data.Text.Array as TArray-import qualified Data.Text.IO as TIO--#if MIN_VERSION_aeson(1,0,0)-import Data.Aeson (ToJSONKey(..),FromJSONKey(..),- ToJSONKeyFunction(..),FromJSONKeyFunction(..))-#endif+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Unboxed.Mutable as MUVector -- $setup --@@ -115,7 +135,7 @@ -- >>> import qualified Prelude as P -- >>> import qualified Data.Text.IO as T -- >>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }---+-- >>> instance Arbitrary IPv4Range where { arbitrary = IPv4Range <$> arbitrary <*> arbitrary } -- | Create an 'IPv4' address from four octets. The first argument -- is the most significant octet. The last argument is the least@@ -241,7 +261,7 @@ builder :: IPv4 -> TBuilder.Builder builder = toDotDecimalBuilder -reader :: Text.Reader IPv4+reader :: TextRead.Reader IPv4 reader = decodeIPv4TextReader parser :: AT.Parser IPv4@@ -274,7 +294,7 @@ | word >= 100 = do let int = fromIntegral word indx = int + int + int- get3 = fromIntegral . BSU.unsafeIndex threeDigits+ get3 = fromIntegral . ByteString.unsafeIndex threeDigits poke ptr (get3 indx) poke (ptr `plusPtr` 1) (get3 (indx + 1)) poke (ptr `plusPtr` 2) (get3 (indx + 2))@@ -282,7 +302,7 @@ | word >= 10 = do let int = fromIntegral word indx = int + int- get2 = fromIntegral . BSU.unsafeIndex twoDigits+ get2 = fromIntegral . ByteString.unsafeIndex twoDigits poke ptr (get2 indx) poke (ptr `plusPtr` 1) (get2 (indx + 1)) return 2@@ -419,7 +439,7 @@ instance ToJSONKey IPv4 where toJSONKey = ToJSONKeyText encode- (\addr -> Aeson.unsafeToEncoding $ BB.char7 '"' <> builderUtf8 addr <> BB.char7 '"')+ (\addr -> Aeson.unsafeToEncoding $ Builder.char7 '"' <> builderUtf8 addr <> Builder.char7 '"') instance FromJSONKey IPv4 where fromJSONKey = FromJSONKeyTextParser aesonParser@@ -633,4 +653,383 @@ picking up a dependency on @network@. -}++-- $setup+--+-- These are here to get doctest's property checking to work.+--+-- >>> import qualified Prelude as P+-- >>> import qualified Data.Text.IO as T+-- >>> import Net.IPv4 (fromOctets,ipv4)+-- >>> import Test.QuickCheck (Arbitrary(..))+-- >>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }+-- >>> instance Arbitrary IPv4Range where { arbitrary = IPv4Range <$> arbitrary <*> arbitrary }+--++-- | Smart constructor for 'IPv4Range'. Ensures the mask is appropriately+-- 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.+--+-- >>> printRange $ fromBounds (fromOctets 192 168 16 0) (fromOctets 192 168 19 255)+-- 192.168.16.0/22+-- >>> printRange $ 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) =+ normalize (IPv4Range (IPv4 a) (maskFromBounds a b))++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'.+--+-- >>> let ip = fromOctets 10 10 1 92+-- >>> contains (IPv4Range (fromOctets 10 0 0 0) 8) ip+-- True+-- >>> contains (IPv4Range (fromOctets 10 11 0 0) 16) ip+-- False+--+-- Typically, element-testing functions are written to take the element+-- as the first argument and the set as the second argument. This is intentionally+-- written the other way for better performance when iterating over a collection.+-- For example, you might test elements in a list for membership like this:+--+-- >>> let r = IPv4Range (fromOctets 10 10 10 6) 31+-- >>> mapM_ (P.print . contains r) (take 5 $ iterate succ $ fromOctets 10 10 10 5)+-- False+-- True+-- True+-- False+-- False+--+-- The implementation of 'contains' ensures that (with GHC), the bitmask+-- creation and range normalization only occur once in the above example.+-- They are reused as the list is iterated.+contains :: IPv4Range -> IPv4 -> Bool+contains (IPv4Range (IPv4 wsubnet) len) =+ let theMask = mask len+ wsubnetNormalized = wsubnet .&. theMask+ in \(IPv4 w) -> (w .&. theMask) == wsubnetNormalized++mask :: Word8 -> Word32+mask = complement . shiftR 0xffffffff . fromIntegral++-- | This is provided to mirror the interface provided by @Data.Set@. It+-- behaves just like 'contains' but with flipped arguments.+--+-- prop> member ip r == contains r ip+member :: IPv4 -> IPv4Range -> Bool+member = flip contains++-- | The inclusive lower bound of an 'IPv4Range'. This is conventionally+-- understood to be the broadcast address of a subnet. For example:+--+-- >>> T.putStrLn $ encode $ lowerInclusive $ IPv4Range (ipv4 10 10 1 160) 25+-- 10.10.1.128+--+-- Note that the lower bound of a normalized 'IPv4Range' is simply the+-- ip address of the range:+--+-- prop> lowerInclusive r == ipv4RangeBase (normalize r)+lowerInclusive :: IPv4Range -> IPv4+lowerInclusive (IPv4Range (IPv4 w) len) =+ IPv4 (w .&. mask len)++upperInclusive :: IPv4Range -> IPv4+upperInclusive (IPv4Range (IPv4 w) len) =+ let theInvertedMask = shiftR 0xffffffff (fromIntegral len)+ theMask = complement theInvertedMask+ in IPv4 ((w .&. theMask) .|. theInvertedMask)++-- Given the size of the mask, return the total number of ips in the subnet. This+-- only works for IPv4 addresses because an IPv6 subnet can have up to 2^128+-- addresses. Not exported.+countAddrs :: Word8 -> Word64+countAddrs w =+ let amountToShift = if w > 32+ then 0+ else 32 - fromIntegral w+ in shift 1 amountToShift++wordSuccessors :: Word64 -> IPv4 -> [IPv4]+wordSuccessors !w (IPv4 !a) = if w > 0+ then IPv4 a : wordSuccessors (w - 1) (IPv4 (a + 1))+ else []++wordSuccessorsM :: MonadPlus m => Word64 -> IPv4 -> m IPv4+wordSuccessorsM = go where+ go !w (IPv4 !a) = if w > 0+ then mplus (return (IPv4 a)) (go (w - 1) (IPv4 (a + 1)))+ else mzero++-- | Convert an 'IPv4Range' into a list of the 'IPv4' addresses that+-- are in it.+-- >>> let r = IPv4Range (fromOctets 192 168 1 8) 30+-- >>> mapM_ (T.putStrLn . encode) (toList r)+-- 192.168.1.8+-- 192.168.1.9+-- 192.168.1.10+-- 192.168.1.11++toList :: IPv4Range -> [IPv4]+toList (IPv4Range ip len) =+ let totalAddrs = countAddrs len+ in wordSuccessors totalAddrs ip++toGenerator :: MonadPlus m => IPv4Range -> m IPv4+toGenerator (IPv4Range ip len) =+ let totalAddrs = countAddrs len+ in wordSuccessorsM totalAddrs ip++-- | The RFC1918 24-bit block. Subnet mask: @10.0.0.0/8@+private24 :: IPv4Range+private24 = IPv4Range (fromOctets 10 0 0 0) 8++-- | The RFC1918 20-bit block. Subnet mask: @172.16.0.0/12@+private20 :: IPv4Range+private20 = IPv4Range (fromOctets 172 16 0 0) 12++-- | The RFC1918 16-bit block. Subnet mask: @192.168.0.0/16@+private16 :: IPv4Range+private16 = IPv4Range (fromOctets 192 168 0 0) 16++-- | Normalize an 'IPv4Range'. The first result of this is that the+-- 'IPv4' inside the 'IPv4Range' is changed so that the insignificant+-- bits are zeroed out. For example:+--+-- >>> printRange $ normalize $ IPv4Range (fromOctets 192 168 1 19) 24+-- 192.168.1.0/24+-- >>> printRange $ normalize $ IPv4Range (fromOctets 192 168 1 163) 28+-- 192.168.1.160/28+--+-- The second effect of this is that the mask length is lowered to+-- be 32 or smaller. Working with 'IPv4Range's that have not been+-- normalized does not cause any issues for this library, although+-- other applications may reject such ranges (especially those with+-- a mask length above 32).+--+-- Note that 'normalize' is idempotent, that is:+--+-- prop> normalize r == (normalize . normalize) r+normalize :: IPv4Range -> IPv4Range+normalize (IPv4Range (IPv4 w) len) =+ let len' = min len 32+ w' = w .&. mask len'+ in IPv4Range (IPv4 w') len'++encodeRange :: IPv4Range -> Text+encodeRange = rangeToDotDecimalText++decodeRange :: Text -> Maybe IPv4Range+decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)++builderRange :: IPv4Range -> TBuilder.Builder+builderRange = rangeToDotDecimalBuilder++parserRange :: AT.Parser IPv4Range+parserRange = do+ ip <- parser+ _ <- AT.char '/'+ theMask <- AT.decimal >>= limitSize+ return (normalize (IPv4Range ip theMask))+ where+ limitSize i =+ if i > 32+ then fail "An IP range length must be between 0 and 32"+ else return i++-- | This exists mostly for testing purposes.+printRange :: IPv4Range -> IO ()+printRange = TIO.putStrLn . encodeRange++-- | The length should be between 0 and 32. These bounds are inclusive.+-- This expectation is not in any way enforced by this library because+-- it does not cause errors. A mask length greater than 32 will be+-- treated as if it were 32.+data IPv4Range = IPv4Range+ { ipv4RangeBase :: {-# UNPACK #-} !IPv4+ , ipv4RangeLength :: {-# UNPACK #-} !Word8+ } deriving (Eq,Ord,Show,Read,Generic)+++instance Hashable IPv4Range++instance ToJSON IPv4Range where+ toJSON = Aeson.String . encodeRange++instance FromJSON IPv4Range where+ parseJSON (Aeson.String t) = case decodeRange t of+ Nothing -> fail "Could not decodeRange IPv4 range"+ Just res -> return res+ parseJSON _ = mzero++data instance MUVector.MVector s IPv4Range = MV_IPv4Range+ !(MUVector.MVector s IPv4)+ !(MUVector.MVector s Word8)+data instance UVector.Vector IPv4Range = V_IPv4Range+ !(UVector.Vector IPv4)+ !(UVector.Vector Word8)++instance UVector.Unbox IPv4Range+instance MGVector.MVector MUVector.MVector IPv4Range where+ {-# INLINE basicLength #-}+ basicLength (MV_IPv4Range as _) = MGVector.basicLength as+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i_ m_ (MV_IPv4Range as bs)+ = MV_IPv4Range (MGVector.basicUnsafeSlice i_ m_ as)+ (MGVector.basicUnsafeSlice i_ m_ bs)+ {-# INLINE basicOverlaps #-}+ basicOverlaps (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)+ = MGVector.basicOverlaps as1 as2+ || MGVector.basicOverlaps bs1 bs2+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n_+ = do+ as <- MGVector.basicUnsafeNew n_+ bs <- MGVector.basicUnsafeNew n_+ return $ MV_IPv4Range as bs+ {-# INLINE basicInitialize #-}+ basicInitialize (MV_IPv4Range as bs)+ = do+ MGVector.basicInitialize as+ MGVector.basicInitialize bs+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeReplicate n_ (IPv4Range a b)+ = do+ as <- MGVector.basicUnsafeReplicate n_ a+ bs <- MGVector.basicUnsafeReplicate n_ b+ return (MV_IPv4Range as bs)+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (MV_IPv4Range as bs) i_+ = do+ a <- MGVector.basicUnsafeRead as i_+ b <- MGVector.basicUnsafeRead bs i_+ return (IPv4Range a b)+ {-# INLINE basicUnsafeWrite #-}+ basicUnsafeWrite (MV_IPv4Range as bs) i_ (IPv4Range a b)+ = do+ MGVector.basicUnsafeWrite as i_ a+ MGVector.basicUnsafeWrite bs i_ b+ {-# INLINE basicClear #-}+ basicClear (MV_IPv4Range as bs)+ = do+ MGVector.basicClear as+ MGVector.basicClear bs+ {-# INLINE basicSet #-}+ basicSet (MV_IPv4Range as bs) (IPv4Range a b)+ = do+ MGVector.basicSet as a+ MGVector.basicSet bs b+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)+ = do+ MGVector.basicUnsafeCopy as1 as2+ MGVector.basicUnsafeCopy bs1 bs2+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeMove (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)+ = do+ MGVector.basicUnsafeMove as1 as2+ MGVector.basicUnsafeMove bs1 bs2+ {-# INLINE basicUnsafeGrow #-}+ basicUnsafeGrow (MV_IPv4Range as bs) m_+ = do+ as' <- MGVector.basicUnsafeGrow as m_+ bs' <- MGVector.basicUnsafeGrow bs m_+ return $ MV_IPv4Range as' bs'++instance GVector.Vector UVector.Vector IPv4Range where+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeFreeze (MV_IPv4Range as bs)+ = do+ as' <- GVector.basicUnsafeFreeze as+ bs' <- GVector.basicUnsafeFreeze bs+ return $ V_IPv4Range as' bs'+ {-# INLINE basicUnsafeThaw #-}+ basicUnsafeThaw (V_IPv4Range as bs)+ = do+ as' <- GVector.basicUnsafeThaw as+ bs' <- GVector.basicUnsafeThaw bs+ return $ MV_IPv4Range as' bs'+ {-# INLINE basicLength #-}+ basicLength (V_IPv4Range as _) = GVector.basicLength as+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i_ m_ (V_IPv4Range as bs)+ = V_IPv4Range (GVector.basicUnsafeSlice i_ m_ as)+ (GVector.basicUnsafeSlice i_ m_ bs)+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeIndexM (V_IPv4Range as bs) i_+ = do+ a <- GVector.basicUnsafeIndexM as i_+ b <- GVector.basicUnsafeIndexM bs i_+ return (IPv4Range a b)+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy (MV_IPv4Range as1 bs1) (V_IPv4Range as2 bs2)+ = do+ GVector.basicUnsafeCopy as1 as2+ GVector.basicUnsafeCopy bs1 bs2+ {-# INLINE elemseq #-}+ elemseq _ (IPv4Range a b)+ = GVector.elemseq (undefined :: UVector.Vector a) a+ . GVector.elemseq (undefined :: UVector.Vector b) b++rangeBitwise :: (IPv4 -> IPv4 -> IPv4) -> IPv4Range -> IPv4Range -> IPv4Range+rangeBitwise fun l r = range ip len+ where+ -- Normalise first+ l' = normalize l+ r' = normalize r+ ip = (ipv4RangeBase l') `fun` (ipv4RangeBase r')+ len = maximum [ipv4RangeLength l, ipv4RangeLength r]++rangeRebase :: (IPv4 -> IPv4) -> IPv4Range -> IPv4Range+rangeRebase fun r = range (fun $ ipv4RangeBase r) (ipv4RangeLength r)++-- | Notes:+--+-- * bit operations use network order (big endian),+--+-- * do not operate on host bits,+--+-- * return a normalized range dropping host bits,+--+-- * and "promote operands" by extending the length to the larger of two+-- ranges.+--+instance Bits.Bits IPv4Range where+ (.&.) = rangeBitwise (.&.)+ (.|.) = rangeBitwise (.|.)+ xor = rangeBitwise Bits.xor+ complement = rangeRebase Bits.complement+ shift r i = rangeRebase (flip Bits.shift i) r+ rotate r i = rangeRebase (flip Bits.rotate i) r+ bitSize = Bits.finiteBitSize+ bitSizeMaybe = Just . Bits.finiteBitSize+ isSigned = Bits.isSigned . ipv4RangeBase+ testBit ip i = Bits.testBit (ipv4RangeBase ip) i+ bit i = IPv4Range (Bits.bit i) $ fromIntegral $ i + 1+ popCount = Bits.popCount . ipv4RangeBase . normalize++-- | Note: the size is determined by the range length+instance Bits.FiniteBits IPv4Range where+ finiteBitSize = fromIntegral . ipv4RangeLength++-----------------+-- Internal Stuff+-----------------++rangeToDotDecimalText :: IPv4Range -> Text+rangeToDotDecimalText = LText.toStrict . TBuilder.toLazyText . rangeToDotDecimalBuilder++rangeToDotDecimalBuilder :: IPv4Range -> TBuilder.Builder+rangeToDotDecimalBuilder (IPv4Range addr len) =+ builder addr+ <> TBuilder.singleton '/'+ <> TBI.decimal len
− src/Net/IPv4/Range.hs
@@ -1,443 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wall #-}-module Net.IPv4.Range- ( -- * Range functions- range- , fromBounds- , normalize- , contains- , member- , lowerInclusive- , upperInclusive- -- * Conversion to IPv4- , toList- , toGenerator- -- * Private Ranges- , private24- , private20- , private16- -- * Textual Conversion- -- ** Text- , encode- , decode- , builder- , parser- , print- -- * Types- , IPv4Range(..)- ) where--import Prelude hiding (print)-import Net.IPv4 (IPv4(..))-import Data.Bits ((.&.),(.|.),shiftR,complement,shift)-import Control.Monad-import Data.Text (Text)-import Data.Word (Word8,Word32,Word64)-import Data.Hashable (Hashable)-import Data.Aeson (FromJSON(..),ToJSON(..))-import GHC.Generics (Generic)-import Data.Monoid ((<>))-import qualified Net.IPv4 as IPv4-import qualified Data.Bits as Bits-import qualified Data.Text.IO as Text-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Lazy.Builder.Int as TBI-import qualified Data.Vector.Generic as GVector-import qualified Data.Vector.Generic.Mutable as MGVector-import qualified Data.Vector.Unboxed.Mutable as MUVector-import qualified Data.Vector.Unboxed as UVector-import qualified Data.Aeson as Aeson-import qualified Data.Text.Lazy as LText---- $setup------ These are here to get doctest's property checking to work.------ >>> import qualified Prelude as P--- >>> import qualified Net.IPv4 as I--- >>> import qualified Data.Text.IO as T--- >>> import Net.IPv4 (fromOctets,ipv4)--- >>> import Test.QuickCheck (Arbitrary(..))--- >>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }--- >>> instance Arbitrary IPv4Range where { arbitrary = IPv4Range <$> arbitrary <*> arbitrary }------- | Smart constructor for 'IPv4Range'. Ensures the mask is appropriately--- 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'.------ >>> let ip = fromOctets 10 10 1 92--- >>> contains (IPv4Range (fromOctets 10 0 0 0) 8) ip--- True--- >>> contains (IPv4Range (fromOctets 10 11 0 0) 16) ip--- False------ Typically, element-testing functions are written to take the element--- as the first argument and the set as the second argument. This is intentionally--- written the other way for better performance when iterating over a collection.--- For example, you might test elements in a list for membership like this:------ >>> let r = IPv4Range (fromOctets 10 10 10 6) 31--- >>> mapM_ (P.print . contains r) (take 5 $ iterate succ $ fromOctets 10 10 10 5)--- False--- True--- True--- False--- False------ The implementation of 'contains' ensures that (with GHC), the bitmask--- creation and range normalization only occur once in the above example.--- They are reused as the list is iterated.-contains :: IPv4Range -> IPv4 -> Bool-contains (IPv4Range (IPv4 wsubnet) len) =- let theMask = mask len- wsubnetNormalized = wsubnet .&. theMask- in \(IPv4 w) -> (w .&. theMask) == wsubnetNormalized--mask :: Word8 -> Word32-mask = complement . shiftR 0xffffffff . fromIntegral---- | This is provided to mirror the interface provided by @Data.Set@. It--- behaves just like 'contains' but with flipped arguments.------ prop> member ip r == contains r ip-member :: IPv4 -> IPv4Range -> Bool-member = flip contains---- | The inclusive lower bound of an 'IPv4Range'. This is conventionally--- understood to be the broadcast address of a subnet. For example:------ >>> T.putStrLn $ I.encode $ lowerInclusive $ IPv4Range (ipv4 10 10 1 160) 25--- 10.10.1.128------ Note that the lower bound of a normalized 'IPv4Range' is simply the--- ip address of the range:------ prop> lowerInclusive r == ipv4RangeBase (normalize r)-lowerInclusive :: IPv4Range -> IPv4-lowerInclusive (IPv4Range (IPv4 w) len) =- IPv4 (w .&. mask len)--upperInclusive :: IPv4Range -> IPv4-upperInclusive (IPv4Range (IPv4 w) len) =- let theInvertedMask = shiftR 0xffffffff (fromIntegral len)- theMask = complement theInvertedMask- in IPv4 ((w .&. theMask) .|. theInvertedMask)---- Given the size of the mask, return the total number of ips in the subnet. This--- only works for IPv4 addresses because an IPv6 subnet can have up to 2^128--- addresses. Not exported.-countAddrs :: Word8 -> Word64-countAddrs w =- let amountToShift = if w > 32- then 0- else 32 - fromIntegral w- in shift 1 amountToShift--wordSuccessors :: Word64 -> IPv4 -> [IPv4]-wordSuccessors !w (IPv4 !a) = if w > 0- then IPv4 a : wordSuccessors (w - 1) (IPv4 (a + 1))- else []--wordSuccessorsM :: MonadPlus m => Word64 -> IPv4 -> m IPv4-wordSuccessorsM = go where- go !w (IPv4 !a) = if w > 0- then mplus (return (IPv4 a)) (go (w - 1) (IPv4 (a + 1)))- else mzero---- | Convert an 'IPv4Range' into a list of the 'IPv4' addresses that--- are in it.--- >>> let r = IPv4Range (fromOctets 192 168 1 8) 30--- >>> mapM_ (T.putStrLn . I.encode) (toList r)--- 192.168.1.8--- 192.168.1.9--- 192.168.1.10--- 192.168.1.11--toList :: IPv4Range -> [IPv4]-toList (IPv4Range ip len) =- let totalAddrs = countAddrs len- in wordSuccessors totalAddrs ip--toGenerator :: MonadPlus m => IPv4Range -> m IPv4-toGenerator (IPv4Range ip len) =- let totalAddrs = countAddrs len- in wordSuccessorsM totalAddrs ip---- | The RFC1918 24-bit block. Subnet mask: @10.0.0.0/8@-private24 :: IPv4Range-private24 = IPv4Range (IPv4.fromOctets 10 0 0 0) 8---- | The RFC1918 20-bit block. Subnet mask: @172.16.0.0/12@-private20 :: IPv4Range-private20 = IPv4Range (IPv4.fromOctets 172 16 0 0) 12---- | The RFC1918 16-bit block. Subnet mask: @192.168.0.0/16@-private16 :: IPv4Range-private16 = IPv4Range (IPv4.fromOctets 192 168 0 0) 16---- | Normalize an 'IPv4Range'. The first result of this is that the--- 'IPv4' inside the 'IPv4Range' is changed so that the insignificant--- bits are zeroed out. For example:------ >>> print $ normalize $ IPv4Range (fromOctets 192 168 1 19) 24--- 192.168.1.0/24--- >>> print $ normalize $ IPv4Range (fromOctets 192 168 1 163) 28--- 192.168.1.160/28------ The second effect of this is that the mask length is lowered to--- be 32 or smaller. Working with 'IPv4Range's that have not been--- normalized does not cause any issues for this library, although--- other applications may reject such ranges (especially those with--- a mask length above 32).------ Note that 'normalize' is idempotent, that is:------ prop> normalize r == (normalize . normalize) r-normalize :: IPv4Range -> IPv4Range-normalize (IPv4Range (IPv4 w) len) =- let len' = min len 32- w' = w .&. mask len'- in IPv4Range (IPv4 w') len'--encode :: IPv4Range -> Text-encode = rangeToDotDecimalText--decode :: Text -> Maybe IPv4Range-decode = rightToMaybe . AT.parseOnly (parser <* AT.endOfInput)--builder :: IPv4Range -> TBuilder.Builder-builder = rangeToDotDecimalBuilder--parser :: AT.Parser IPv4Range-parser = do- ip <- IPv4.parser- _ <- AT.char '/'- theMask <- AT.decimal >>= limitSize- return (normalize (IPv4Range ip theMask))- where- limitSize i =- if i > 32- then fail "An IP range length must be between 0 and 32"- else return i---- | This exists mostly for testing purposes.-print :: IPv4Range -> IO ()-print = Text.putStrLn . encode--rightToMaybe :: Either a b -> Maybe b-rightToMaybe = either (const Nothing) Just---- | The length should be between 0 and 32. These bounds are inclusive.--- This expectation is not in any way enforced by this library because--- it does not cause errors. A mask length greater than 32 will be--- treated as if it were 32.-data IPv4Range = IPv4Range- { ipv4RangeBase :: {-# UNPACK #-} !IPv4- , ipv4RangeLength :: {-# UNPACK #-} !Word8- } deriving (Eq,Ord,Show,Read,Generic)---instance Hashable IPv4Range--instance ToJSON IPv4Range where- toJSON = Aeson.String . encode--instance FromJSON IPv4Range where- parseJSON (Aeson.String t) = case decode t of- Nothing -> fail "Could not decode IPv4 range"- Just res -> return res- parseJSON _ = mzero--data instance MUVector.MVector s IPv4Range = MV_IPv4Range- !(MUVector.MVector s IPv4)- !(MUVector.MVector s Word8)-data instance UVector.Vector IPv4Range = V_IPv4Range- !(UVector.Vector IPv4)- !(UVector.Vector Word8)--instance UVector.Unbox IPv4Range-instance MGVector.MVector MUVector.MVector IPv4Range where- {-# INLINE basicLength #-}- basicLength (MV_IPv4Range as _) = MGVector.basicLength as- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (MV_IPv4Range as bs)- = MV_IPv4Range (MGVector.basicUnsafeSlice i_ m_ as)- (MGVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicOverlaps #-}- basicOverlaps (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)- = MGVector.basicOverlaps as1 as2- || MGVector.basicOverlaps bs1 bs2- {-# INLINE basicUnsafeNew #-}- basicUnsafeNew n_- = do- as <- MGVector.basicUnsafeNew n_- bs <- MGVector.basicUnsafeNew n_- return $ MV_IPv4Range as bs- {-# INLINE basicInitialize #-}- basicInitialize (MV_IPv4Range as bs)- = do- MGVector.basicInitialize as- MGVector.basicInitialize bs- {-# INLINE basicUnsafeReplicate #-}- basicUnsafeReplicate n_ (IPv4Range a b)- = do- as <- MGVector.basicUnsafeReplicate n_ a- bs <- MGVector.basicUnsafeReplicate n_ b- return (MV_IPv4Range as bs)- {-# INLINE basicUnsafeRead #-}- basicUnsafeRead (MV_IPv4Range as bs) i_- = do- a <- MGVector.basicUnsafeRead as i_- b <- MGVector.basicUnsafeRead bs i_- return (IPv4Range a b)- {-# INLINE basicUnsafeWrite #-}- basicUnsafeWrite (MV_IPv4Range as bs) i_ (IPv4Range a b)- = do- MGVector.basicUnsafeWrite as i_ a- MGVector.basicUnsafeWrite bs i_ b- {-# INLINE basicClear #-}- basicClear (MV_IPv4Range as bs)- = do- MGVector.basicClear as- MGVector.basicClear bs- {-# INLINE basicSet #-}- basicSet (MV_IPv4Range as bs) (IPv4Range a b)- = do- MGVector.basicSet as a- MGVector.basicSet bs b- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)- = do- MGVector.basicUnsafeCopy as1 as2- MGVector.basicUnsafeCopy bs1 bs2- {-# INLINE basicUnsafeMove #-}- basicUnsafeMove (MV_IPv4Range as1 bs1) (MV_IPv4Range as2 bs2)- = do- MGVector.basicUnsafeMove as1 as2- MGVector.basicUnsafeMove bs1 bs2- {-# INLINE basicUnsafeGrow #-}- basicUnsafeGrow (MV_IPv4Range as bs) m_- = do- as' <- MGVector.basicUnsafeGrow as m_- bs' <- MGVector.basicUnsafeGrow bs m_- return $ MV_IPv4Range as' bs'--instance GVector.Vector UVector.Vector IPv4Range where- {-# INLINE basicUnsafeFreeze #-}- basicUnsafeFreeze (MV_IPv4Range as bs)- = do- as' <- GVector.basicUnsafeFreeze as- bs' <- GVector.basicUnsafeFreeze bs- return $ V_IPv4Range as' bs'- {-# INLINE basicUnsafeThaw #-}- basicUnsafeThaw (V_IPv4Range as bs)- = do- as' <- GVector.basicUnsafeThaw as- bs' <- GVector.basicUnsafeThaw bs- return $ MV_IPv4Range as' bs'- {-# INLINE basicLength #-}- basicLength (V_IPv4Range as _) = GVector.basicLength as- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (V_IPv4Range as bs)- = V_IPv4Range (GVector.basicUnsafeSlice i_ m_ as)- (GVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicUnsafeIndexM #-}- basicUnsafeIndexM (V_IPv4Range as bs) i_- = do- a <- GVector.basicUnsafeIndexM as i_- b <- GVector.basicUnsafeIndexM bs i_- return (IPv4Range a b)- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_IPv4Range as1 bs1) (V_IPv4Range as2 bs2)- = do- GVector.basicUnsafeCopy as1 as2- GVector.basicUnsafeCopy bs1 bs2- {-# INLINE elemseq #-}- elemseq _ (IPv4Range a b)- = GVector.elemseq (undefined :: UVector.Vector a) a- . GVector.elemseq (undefined :: UVector.Vector b) b--rangeBitwise :: (IPv4 -> IPv4 -> IPv4) -> IPv4Range -> IPv4Range -> IPv4Range-rangeBitwise fun l r = range ip len- where- -- Normalise first- l' = normalize l- r' = normalize r- ip = (ipv4RangeBase l') `fun` (ipv4RangeBase r')- len = maximum [ipv4RangeLength l, ipv4RangeLength r]--rangeRebase :: (IPv4 -> IPv4) -> IPv4Range -> IPv4Range-rangeRebase fun r = range (fun $ ipv4RangeBase r) (ipv4RangeLength r)---- | Notes:------ * bit operations use network order (big endian),------ * do not operate on host bits,------ * return a normalized range dropping host bits,------ * and "promote operands" by extending the length to the larger of two--- ranges.----instance Bits.Bits IPv4Range where- (.&.) = rangeBitwise (.&.)- (.|.) = rangeBitwise (.|.)- xor = rangeBitwise Bits.xor- complement = rangeRebase Bits.complement- shift r i = rangeRebase (flip Bits.shift i) r- rotate r i = rangeRebase (flip Bits.rotate i) r- bitSize = Bits.finiteBitSize- bitSizeMaybe = Just . Bits.finiteBitSize- isSigned = Bits.isSigned . ipv4RangeBase- testBit ip i = Bits.testBit (ipv4RangeBase ip) i- bit i = IPv4Range (Bits.bit i) $ fromIntegral $ i + 1- popCount = Bits.popCount . ipv4RangeBase . normalize---- | Note: the size is determined by the range length-instance Bits.FiniteBits IPv4Range where- finiteBitSize = fromIntegral . ipv4RangeLength---------------------- Internal Stuff--------------------rangeToDotDecimalText :: IPv4Range -> Text-rangeToDotDecimalText = LText.toStrict . TBuilder.toLazyText . rangeToDotDecimalBuilder--rangeToDotDecimalBuilder :: IPv4Range -> TBuilder.Builder-rangeToDotDecimalBuilder (IPv4Range addr len) =- IPv4.builder addr- <> TBuilder.singleton '/'- <> TBI.decimal len-
src/Net/IPv6.hs view
@@ -4,14 +4,14 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Net.IPv6- ( -- * Types- IPv6(..)- -- * Convert- , ipv6+ ( -- * Convert+ ipv6 , fromOctets , fromWord16s , fromWord32s@@ -29,6 +29,24 @@ , parser -- ** Printing , print+ -- * IPv6 Ranges+ -- ** Range functions+ , range+ , fromBounds+ , normalize+ , contains+ , member+ , lowerInclusive+ , upperInclusive+ -- ** Textual Conversion+ -- *** Text+ , encodeRange+ , decodeRange+ , parserRange+ , printRange+ -- * Types+ , IPv6(..)+ , IPv6Range(..) ) where import Net.IPv4 (IPv4(..))@@ -38,6 +56,7 @@ import Control.Monad.Primitive import Control.Monad.ST import Data.Bits+import Data.ByteString (ByteString) import Data.Char (chr) import Data.List (intercalate, group) import Data.Primitive.Addr@@ -45,14 +64,18 @@ import Data.Primitive.Types (Prim(..)) import Data.Text (Text) import Data.Word+import GHC.Enum (predError, succError) import GHC.Exts+import GHC.Generics (Generic) import Numeric (showHex) import Prelude hiding (any, print) import Text.ParserCombinators.ReadPrec (prec,step)+import Text.Printf (printf) import Text.Read (Read(..),Lexeme(Ident),lexP,parens) import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.Text as Atto+import qualified Data.ByteString.Char8 as BC8 import qualified Data.Text as Text import qualified Data.Text.IO as TIO @@ -62,6 +85,9 @@ -- -- >>> import qualified Prelude as P -- >>> import qualified Data.Text.IO as T+-- >>> import Test.QuickCheck (Arbitrary(..))+-- >>> instance Arbitrary IPv6 where { arbitrary = IPv6 <$> arbitrary <*> arbitrary }+-- >>> instance Arbitrary IPv6Range where { arbitrary = IPv6Range <$> arbitrary <*> arbitrary } -- -- | A 128-bit Internet Protocol version 6 address.@@ -70,6 +96,58 @@ , ipv6B :: {-# UNPACK #-} !Word64 } deriving (Eq,Ord) +-- | Since 'IPv6' has more inhabitants than 'Int', the+-- implementation of 'fromEnum' discards information.+-- Currently, 'enumFromThen' and 'enumFromThenTo' emit+-- an error, but this could be remedied if someone+-- wants to provide an implementation of them.+instance Enum IPv6 where+ succ (IPv6 a b) + | a == maxBound && b == maxBound = succError "IPv6"+ | otherwise =+ case b + 1 of+ 0 -> IPv6 (a + 1) 0+ s -> IPv6 a s++ pred (IPv6 a b)+ | a == 0 && b == 0 = predError "IPv6"+ | otherwise =+ case b of+ 0 -> IPv6 (a - 1) maxBound+ _ -> IPv6 a (b - 1)++ toEnum :: Int -> IPv6+ toEnum i = IPv6 0 (toEnum i)++ fromEnum :: IPv6 -> Int+ fromEnum (IPv6 _ b) = fromEnum b++ {-# INLINE enumFrom #-}+ enumFrom x = unfoldrLast (Just maxBound) (\b -> if b < maxBound then Just (b,succ b) else Nothing) x+ {-# INLINE enumFromTo #-}+ enumFromTo x y = unfoldrLast (if x <= y then Just y else Nothing) (\b -> if b < y then Just (b,succ b) else Nothing) x++ enumFromThen = error "IPv6 currently lacks an implementation of enumFromThen"+ enumFromThenTo = error "IPv6 currently lacks an implementation of enumFromThenTo"++-- This is like unfoldr except that it adds an additional element+-- at the end.+unfoldrLast :: Maybe a -> (b -> Maybe (a, b)) -> b -> [a]+{-# INLINE unfoldrLast #-}+unfoldrLast a0 f b0 = build+ (\c n ->+ let go b = case f b of+ Just (a, new_b) -> a `c` go new_b+ Nothing -> case a0 of+ Nothing -> n+ Just x -> x `c` n+ in go b0+ )++instance Bounded IPv6 where+ minBound = IPv6 0 0+ maxBound = IPv6 maxBound maxBound+ instance Show IPv6 where showsPrec p addr = showParen (p > 10) $ showString "ipv6 "@@ -316,84 +394,52 @@ decode t = rightToMaybe (AT.parseOnly (parser <* AT.endOfInput) t) parser :: Atto.Parser IPv6-parser = startIP >>= makeIP+parser = makeIP <$> ip where- -- handles the case where an IP starts with ::- startIP :: Atto.Parser ([Word16], Maybe [Word16])- startIP = - (\ends -> ([], Just ends)) <$> (Atto.char ':' *> Atto.char ':' *> restOfIP []) <|>- fullIP []+ makeIP [w1, w2, w3, w4, w5, w6, w7, w8] = fromWord16s w1 w2 w3 w4 w5 w6 w7 w8+ makeIP _ = error "Net.IPv6.parser: Implementation error. Please open a bug report." - -- a full IP that might contain ::- fullIP :: [Word16] -> Atto.Parser ([Word16], Maybe [Word16])- fullIP starts =- ((\x -> (x ++ starts, Nothing)) <$> ipv4) <|>- startPart starts+ ip = (Atto.char ':' *> Atto.char ':' *> doubleColon 0) <|> part 0 - -- 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)+ part :: Int -> Atto.Parser [Word16]+ part n =+ case n of+ -- max 8 parts in an IPv6 address+ 7 -> pure <$> Atto.hexadecimal+ -- after 6 parts it could end in IPv4 dotted notation+ 6 -> ipv4 <|> hexPart+ _ -> hexPart+ where+ hexPart = (:)+ <$> Atto.hexadecimal+ <*> (Atto.char ':' *>+ (+ (Atto.char ':' *> doubleColon (n+1))+ <|>+ part (n+1)+ )+ ) - -- 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+ doubleColon :: Int -> Atto.Parser [Word16]+ doubleColon count = do+ rest <- afterDoubleColon <|> pure []+ let fillerLength = (8 - count - length rest)+ if fillerLength <= 0+ then fail "too many parts in IPv6 address"+ else pure (replicate fillerLength 0 ++ rest) - 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+ -- after double colon, IPv4 dotted notation could appear anywhere+ afterDoubleColon :: Atto.Parser [Word16]+ afterDoubleColon =+ ipv4 <|>+ (:) <$> Atto.hexadecimal <*> ((Atto.char ':' *> afterDoubleColon) <|> pure []) + ipv4 :: Atto.Parser [Word16]+ ipv4 = ipv4ToWord16s <$> IPv4.parser++ ipv4ToWord16s :: IPv4 -> [Word16]+ ipv4ToWord16s (IPv4 word) = [fromIntegral (word `unsafeShiftR` 16), fromIntegral (word .&. 0xFFFF)]+ fromOctetsV6 :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64@@ -445,4 +491,125 @@ fromWord32Word64 :: Word64 -> Word64 -> Word64 fromWord32Word64 a b = fromIntegral (unsafeShiftL a 32 .|. b)++data IPv6Range = IPv6Range+ { ipv6RangeBase :: {-# UNPACK #-} !IPv6+ , ipv6RangeLength :: {-# UNPACK #-} !Word8+ } deriving (Eq,Ord,Show,Read,Generic)++mask :: Word8 -> Word64+mask w = if w > 63+ then 0xffffffffffffffff + else complement (shiftR 0xffffffffffffffff (fromIntegral w))++normalize :: IPv6Range -> IPv6Range+normalize (IPv6Range (IPv6 w1 w2) len) =+ let len' = min len 128+ norm+ | len' < 64 = (IPv6Range (IPv6 (w1 .&. mask len') (w2 .&. mask 0)) len')+ | otherwise = (IPv6Range (IPv6 (w1 .&. mask 64) (w2 .&. mask (len' - 64))) len')+ in norm++encodeRange :: IPv6Range -> Text+encodeRange x = encode (ipv6RangeBase x) <> Text.pack "/" <> (Text.pack $ (show . fromEnum) $ ipv6RangeLength x)++decodeRange :: Text -> Maybe IPv6Range+decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)++parserRange :: AT.Parser IPv6Range+parserRange = do+ ip <- parser+ _ <- AT.char '/'+ theMask <- AT.decimal >>= limitSize+ return (normalize (IPv6Range ip theMask))+ where+ limitSize i =+ if i > 128+ then fail "An IP range length must be between 0 and 128"+ else return i++-- | Checks to see if an 'IPv6' address belongs in the 'IPv6Range'.+--+-- >>> let ip = ipv6 0x2001 0x0db8 0x0db8 0x1094 0x2051 0x0000 0x0000 0x0001+-- >>> let iprange mask = IPv6Range (ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) mask+-- >>> contains (iprange 8) ip+-- True+-- >>> contains (iprange 48) ip+-- False+--+-- Typically, element-testing functions are written to take the element+-- as the first argument and the set as the second argument. This is intentionally+-- written the other way for better performance when iterating over a collection.+-- For example, you might test elements in a list for membership like this:+--+-- >>> let r = IPv6Range (ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) 64+-- >>> fmap (contains r) (take 5 $ iterate succ $ ipv6 0x2001 0x0db8 0x0000 0x0000 0xffff 0xffff 0xffff 0xfffe)+-- [True,True,False,False,False]+--+-- The implementation of 'contains' ensures that (with GHC), the bitmask+-- creation and range normalization only occur once in the above example.+-- They are reused as the list is iterated.+contains :: IPv6Range -> IPv6 -> Bool+contains (IPv6Range (IPv6 wsubnetA wsubnetB) len) = + let lenA = if len > 64 then 64 else len+ lenB = if len > 64 then len - 64 else 0+ theMaskA = mask lenA+ theMaskB = mask lenB+ wsubnetNormalizedA = wsubnetA .&. theMaskA+ wsubnetNormalizedB = wsubnetB .&. theMaskB+ in \(IPv6 wA wB) ->+ (wA .&. theMaskA) == wsubnetNormalizedA+ &&+ (wB .&. theMaskB) == wsubnetNormalizedB++-- | This is provided to mirror the interface provided by @Data.Set@. It+-- behaves just like 'contains' but with flipped arguments.+--+-- prop> member ip r == contains r ip+member :: IPv6 -> IPv6Range -> Bool+member = flip contains++-- | The inclusive lower bound of an 'IPv6Range'. This is conventionally+-- understood to be the broadcast address of a subnet. For example:+--+-- >>> T.putStrLn $ encode $ lowerInclusive $ IPv6Range (ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) 25+-- 2001:d80::+--+-- Note that the lower bound of a normalized 'IPv4Range' is simply the+-- ip address of the range:+--+-- prop> lowerInclusive r == ipv6RangeBase (normalize r)+lowerInclusive :: IPv6Range -> IPv6+lowerInclusive (IPv6Range (IPv6 w1 w2) len) =+ ipv6RangeBase (normalize (IPv6Range (IPv6 w1 w2) len))++upperInclusive :: IPv6Range -> IPv6+upperInclusive (IPv6Range (IPv6 w1 w2) len) =+ let len' = min 128 len+ theInvertedMask :: Word64+ theInvertedMask = shiftR 0xffffffffffffffff (fromIntegral len')+ theInvertedMask2 = shiftR 0xffffffffffffffff ((fromIntegral len')-64)+ upper+ | len' < 64 = IPv6 ((w1 .|. theInvertedMask)) ((w2 .|. shiftR 0xffffffffffffffff 0))+ | otherwise = IPv6 (w1) (w2 .|. theInvertedMask2)+ in upper++-- | This exists mostly for testing purposes.+printRange :: IPv6Range -> IO ()+printRange = TIO.putStrLn . encodeRange++range :: IPv6 -> Word8 -> IPv6Range+range addr len = normalize (IPv6Range addr len)++fromBounds :: IPv6 -> IPv6 -> IPv6Range+fromBounds (IPv6 a1 a2) (IPv6 b1 b2) =+ normalize (IPv6Range (IPv6 a1 a2) (maskFromBounds a1 b1 a2 b2))++maskFromBounds :: Word64 -> Word64 -> Word64 -> Word64 -> Word8+maskFromBounds lo1 hi1 lo2 hi2 =+ let x = countLeadingZeros (xor lo1 hi1)+ check+ | x < 64 = fromIntegral x+ | otherwise = fromIntegral $ x + (countLeadingZeros (xor lo2 hi2))+ in check
src/Net/Types.hs view
@@ -5,14 +5,14 @@ , IPv6(..) , IP(..) , IPv4Range(..)+ , IPv6Range(..) , Mac(..) , MacCodec(..) , MacGrouping(..) ) where -import Net.IPv6 (IPv6(..))-import Net.IPv4 (IPv4(..))-import Net.IPv4.Range (IPv4Range(..))+import Net.IPv6 (IPv6(..),IPv6Range(..))+import Net.IPv4 (IPv4(..), IPv4Range(..)) import Net.IP (IP(..)) import Net.Mac (Mac(..),MacCodec(..),MacGrouping(..))
test/Doctests.hs view
@@ -5,7 +5,6 @@ [ "src/Net/IPv4.hs" , "src/Net/IPv6.hs" , "src/Net/IP.hs"- , "src/Net/IPv4/Range.hs" , "src/Data/Word/Synthetic/Word12.hs" , "src/Data/Text/Builder/Common/Internal.hs" , "src/Data/Text/Builder/Fixed.hs"
test/Test.hs view
@@ -6,23 +6,23 @@ module Main (main) where import Naive+import Control.Applicative (liftA2) import Data.Proxy (Proxy(..)) import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(..),Property,oneof,Gen,elements,choose)+import Test.QuickCheck (Arbitrary(..),Property,oneof,Gen,elements,choose,(===)) import Test.HUnit (Assertion,(@?=),(@=?)) import Numeric (showHex) import Test.QuickCheck.Property (failed,succeeded,Result(..)) import Data.Bifunctor-import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws,bitsLaws,primLaws)+import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws,bitsLaws,primLaws,boundedEnumLaws) import qualified Test.Framework.Providers.HUnit as PH -import Net.Types (IP,IPv4(..),IPv4Range(..),Mac(..),IPv6(..),MacGrouping(..),MacCodec(..))+import Net.Types (IP,IPv4(..),IPv4Range(..),Mac(..),IPv6(..),MacGrouping(..),MacCodec(..),IPv6Range(..)) import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BC8 import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6-import qualified Net.IPv4.Range as IPv4Range import qualified Net.Mac as Mac import qualified Net.IP as IP @@ -88,13 +88,36 @@ , PH.testCase "Parser Failure Test Cases" testIPv6ParserFailure ] ]- , testGroup "IP Range Operations"+ , testGroup "IPv4 Range Operations" [ testProperty "Idempotence of normalizing IPv4 range"- $ propIdempotence IPv4Range.normalize+ $ propIdempotence IPv4.normalize , testProperty "Normalize does not affect membership" propNormalizeMember , testProperty "Membership agrees with bounds" propMemberUpperLower , testProperty "Range contains self" propRangeSelf ]+ , testGroup "IPv6 Range Operations"+ [ testProperty "Idempotence of normalizing IPv6 range"+ $ propIdempotence IPv6.normalize+ , testProperty "Normalize does not affect membership" $ \i r ->+ IPv6.member i r == IPv6.member i (IPv6.normalize r)+ , testProperty "Membership agrees with bounds" $ \i r ->+ (i >= IPv6.lowerInclusive r && i <= IPv6.upperInclusive r) == IPv6.member i r+ , testProperty "Range contains self" $ \r ->+ IPv6.member (ipv6RangeBase r) r == True+ , testProperty "Idempotence of upperInclusive-lowerInclusive and fromBounds" $ \r ->+ IPv6.fromBounds (IPv6.lowerInclusive r) (IPv6.upperInclusive r) === r+ , testGroup "Cases"+ [ PH.testCase "A" $ False @=? IPv6.contains+ (IPv6.range (IPv6.ipv6 0 0 0 1 0 0 0 0) 64)+ (IPv6.ipv6 0 0 0 0 0 0 0 0)+ , PH.testCase "B" $ True @=? IPv6.contains+ (IPv6.range (IPv6.ipv6 0 0 0 0 0 0 0 0) 126)+ (IPv6.ipv6 0 0 0 0 0 0 0 1)+ , PH.testCase "C" $ False @=? IPv6.contains+ (IPv6.range (IPv6.ipv6 0 0 0 0 0 0 0 0) 125)+ (IPv6.ipv6 0 0 0 0 0 0 0 0xFFFF)+ ]+ ] , testGroup "Instances" [ testGroup "IPv4" [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4))@@ -110,6 +133,7 @@ [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6)) , lawsToTest (showReadLaws (Proxy :: Proxy IPv6)) , lawsToTest (primLaws (Proxy :: Proxy IPv6))+ , lawsToTest (boundedEnumLaws (Proxy :: Proxy IPv6)) ] , testGroup "IP" [ lawsToTest (jsonLaws (Proxy :: Proxy IP))@@ -150,14 +174,14 @@ propIdempotence f a = f a == f (f a) propNormalizeMember :: IPv4 -> IPv4Range -> Bool-propNormalizeMember i r = IPv4Range.member i r == IPv4Range.member i (IPv4Range.normalize r)+propNormalizeMember i r = IPv4.member i r == IPv4.member i (IPv4.normalize r) propMemberUpperLower :: IPv4 -> IPv4Range -> Bool propMemberUpperLower i r =- (i >= IPv4Range.lowerInclusive r && i <= IPv4Range.upperInclusive r) == IPv4Range.member i r+ (i >= IPv4.lowerInclusive r && i <= IPv4.upperInclusive r) == IPv4.member i r propRangeSelf :: IPv4Range -> Bool-propRangeSelf r = IPv4Range.member (ipv4RangeBase r) r == True+propRangeSelf r = IPv4.member (ipv4RangeBase r) r == True testIPv4Decode :: Assertion testIPv4Decode = IPv4.decode (Text.pack "124.222.255.0")@@ -218,16 +242,46 @@ testIPv6ParserFailure :: Assertion testIPv6ParserFailure = do- go "1111:2222:3333:4444:5555:6666::7777:8888"+ -- must not start or end in colon:+ go ":::"+ go "1::2:"+ go ":1::2"+ go "1:::"+ go ":1::"+ go "::1:"+ go "1:2:3:4:5:6:777:8:"+ go ":1:2:3:4:5:6:7777:8"++ -- Incorrect numbers of parts:+ go ""+ go "1111"+ go "1111:2222"+ go "1111:2222:3333"+ go "1111:2222:3333:4444"+ go "1111:2222:3333:4444:5555"+ go "1111:2222:3333:4444:5555:6666"+ go "1111:2222:3333:4444:5555:6666:7777" 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+ -- Incorrect use of double-colon:+ go "1111::2222::3333"+ go "1111:2222:3333:4444:5555:6666::7777:8888" -- not needed+ go "1111:2222:3333:4444:5555:6666:7777:8888::9999" -- too long++ -- IPv4 decimal embedded, with not enough parts:+ go "1:127.0.0.1" 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+ -- IPv4 decimal before double-colon:+ go "1:127.0.0.1::"++ -- Only IPv4:+ go "127.0.0.1"++ -- IPv4 decimal embedded, with too many parts:+ go "1:2:3:4:5:6:7:127.0.0.1" go "1:2:3:4:5:6:7:8:127.0.0.1" where go str =@@ -235,53 +289,53 @@ @=? bimap (\_ -> ()) HexIPv6 (AT.parseOnly (IPv6.parser <* AT.endOfInput)- (Text.pack str)- )+ (Text.pack str)) testIPv6Encode :: Assertion testIPv6Encode = do - -- degenerate cases:- "::" `roundTripsTo` "::"- "1234::" `roundTripsTo` "1234::"- "::1234" `roundTripsTo` "::1234"+ -- degenerate cases:+ "::" `roundTripsTo` "::"+ "1234::" `roundTripsTo` "1234::"+ "::1234" `roundTripsTo` "::1234" - -- zero-compression works:- "1234:1234:0000:0000:0000:0000:3456:3434" `roundTripsTo` "1234:1234::3456:3434"+ -- zero-compression works:+ "1234:1234:0000:0000:0000:0000:3456:3434" `roundTripsTo` "1234:1234::3456:3434" - -- picks first case:- "1234:0000:1234:0000:1234:0000:0123:1234" `roundTripsTo` "1234::1234:0:1234:0:123:1234"+ -- picks first case:+ "1234:0000:1234:0000:1234:0000:0123:1234" `roundTripsTo` "1234::1234:0:1234:0:123:1234" - -- picks longest case:- "1234:0000:1234:0000:0:0000:0123:1234" `roundTripsTo` "1234:0:1234::123:1234"+ -- picks longest case:+ "1234:0000:1234:0000:0:0000:0123:1234" `roundTripsTo` "1234:0:1234::123:1234" - -- can exclude all but first and last:- "1234::1234" `roundTripsTo` "1234::1234"+ -- can exclude all but first and last:+ "1234::1234" `roundTripsTo` "1234::1234" - -- prefers leftmost part to zero-compress:- "1:2:0:0:5::8" `roundTripsTo` "1:2::5:0:0:8"+ -- prefers leftmost part to zero-compress:+ "1:2:0:0:5::8" `roundTripsTo` "1:2::5:0:0:8" - -- can work with no zeroes:- "1:2:3:4:5:6:7:8" `roundTripsTo` "1:2:3:4:5:6:7:8"+ -- can work with no zeroes:+ "1:2:3:4:5:6:7:8" `roundTripsTo` "1:2:3:4:5:6:7:8" - -- 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::"+ -- 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` "::"+ -- 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"+ -- 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"+ "1234:5678::10.0.1.2" `roundTripsTo` "1234:5678::a00:102" - where- roundTripsTo s sExpected =- case AT.parseOnly (IPv6.parser <* AT.endOfInput) (Text.pack s) of- Right result -> IPv6.encode result @?= Text.pack sExpected- Left failMsg -> fail failMsg -- parse shouldn't fail here+ where+ roundTripsTo s sExpected =+ case AT.parseOnly (IPv6.parser <* AT.endOfInput) (Text.pack s) of+ Right result -> IPv6.encode result @?= Text.pack sExpected+ Left failMsg -> fail ("failed to parse '" ++ s ++ "': " ++ failMsg) textBadIPv4 :: [String] textBadIPv4 =@@ -343,6 +397,11 @@ instance Arbitrary IPv6 where arbitrary = IPv6 <$> arbitrary <*> arbitrary+ shrink (IPv6 a b) = filter (/= IPv6 a b)+ [ IPv6 0 0+ , IPv6 (div a 2) b+ , IPv6 a (div b 2)+ ] -- Half of the test cases generated are IPv6 mapped -- IPv4 addresses.@@ -364,7 +423,14 @@ -- This instance can generate masks that exceed the recommended -- length of 32. instance Arbitrary IPv4Range where- arbitrary = IPv4Range.range <$> arbitrary <*> choose (0,32)+ arbitrary = IPv4.range <$> arbitrary <*> choose (0,32)++instance Arbitrary IPv6Range where+ arbitrary = IPv6.range <$> arbitrary <*> choose (0,128)+ shrink (IPv6Range addr mask) = liftA2 IPv6.range+ (shrink addr)+ (filter (/= mask) [0,div mask 2,if mask > 0 then mask - 1 else 0])+ instance Arbitrary MacCodec where arbitrary = MacCodec <$> arbitrary <*> arbitrary