network-ip (empty) → 0.0.1
raw patch · 5 files changed
+987/−0 lines, 5 filesdep +QuickCheckdep +basedep +binarysetup-changed
Dependencies added: QuickCheck, base, binary, cereal, data-default, data-dword, data-endian, data-textual, hashable, network-ip, parsers, tagged, test-framework, test-framework-quickcheck2, text-printer
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- network-ip.cabal +60/−0
- src/Network/IP/Addr.hs +672/−0
- tests/Tests.hs +226/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011-2013 Mikhail Vorozhtsov+All rights reserved.++Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ network-ip.cabal view
@@ -0,0 +1,60 @@+Name: network-ip+Version: 0.0.1+Category: Network+Stability: experimental+Synopsis: Internet Protocol data structures+Description:+ This package provides Internet Protocol data structures++Homepage: https://github.com/mvv/network-ip+Bug-Reports: https://github.com/mvv/network-ip/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2011-2013 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Cabal-Version: >= 1.10.0+Build-Type: Simple++Source-Repository head+ Type: git+ Location: https://github.com/mvv/network-ip.git++Library+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4.3 && < 5,+ data-default >= 0.2,+ data-endian >= 0.0.1,+ data-dword >= 0.2,+ tagged >= 0.2,+ hashable >= 1.1,+ binary >= 0.5,+ cereal >= 0.3,+ text-printer >= 0.3,+ data-textual >= 0.1,+ parsers >= 0.5+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules:+ Network.IP.Addr++Test-Suite tests+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Build-Depends:+ base >= 4 && < 5,+ test-framework >= 0.6,+ test-framework-quickcheck2 >= 0.2,+ QuickCheck >= 2.4,+ data-dword,+ text-printer,+ data-textual,+ parsers,+ network-ip+ Hs-Source-Dirs: tests+ GHC-Options: -Wall+ Main-Is: Tests.hs+
+ src/Network/IP/Addr.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}++-- | Internet Protocol addressing.+module Network.IP.Addr+ ( + -- * Host address+ -- ** IPv4 address+ IP4(..)+ , anIP4+ , ip4ToOctets+ , ip4ToOctetList+ , ip4FromOctets+ , ip4FromOctetList+ , anyIP4+ -- ** IPv6 address+ , IP6(..)+ , anIP6+ , ip6ToWords+ , ip6ToWordList+ , ip6FromWords+ , ip6FromWordList+ , anyIP6+ -- ** IP address+ , IP(..)+ , anIP+ -- * Network address+ , IsNetAddr(..)+ , Net4Addr+ , Net6Addr+ , NetAddr+ , aNetAddr+ , aNetAddrOf+ , aNet4Addr+ , aNet6Addr+ , aNetAddrIP+ , printNetAddr+ , net4Parser+ , net6Parser+ , netParser+ -- * Port number+ , InetPort(..)+ , anInetPort+ -- * Socket address+ , InetAddr(..)+ , Inet4Addr+ , Inet6Addr+ , anInetAddr+ , anInetAddrOf+ , anInet4Addr+ , anInet6Addr+ , anInetAddrIP+ ) where++import Prelude hiding (print)+import Data.Typeable (Typeable, Typeable1)+import Data.Proxy (Proxy(..))+import Data.Word+import Data.Bits+import Data.DoubleWord (BinaryWord(..), DoubleWord(..), Word128)+import Data.Ix (Ix)+import Data.Endian+import Data.Default+import Data.Hashable+import Data.Binary (Binary)+import qualified Data.Binary as B+import Data.Serialize (Serialize)+import qualified Data.Serialize as S+import Text.Printer (Printer, (<>))+import qualified Text.Printer as P+import qualified Text.Printer.Numerals as P+import Data.Textual+import Data.Textual.Numerals hiding (Binary)+import Text.Parser.Combinators ((<?>), try)+import Text.Parser.Char (CharParsing)+import qualified Text.Parser.Char as PC+import Text.Printf (printf)+import Control.Applicative+import Control.Monad (void, when)+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))++-- | IPv4 address.+newtype IP4 = IP4 { unIP4 ∷ Word32 }+ deriving (Typeable, Eq, Ord, Bounded, Enum, Ix, Num, Bits, Hashable,+ Binary, Serialize)++-- | 'IP4' proxy value.+anIP4 ∷ Proxy IP4+anIP4 = Proxy++instance Show IP4 where+ showsPrec p a = showParen (p > 10)+ $ showString "ip4FromOctets "+ . showsPrec 11 o1+ . showString " "+ . showsPrec 11 o2+ . showString " "+ . showsPrec 11 o3+ . showString " "+ . showsPrec 11 o4+ where (o1, o2, o3, o4) = ip4ToOctets a++instance Printable IP4 where+ print = P.fsep (P.char7 '.') . (P.nonNegative Decimal <$>) . ip4ToOctetList+ {-# INLINE print #-}++instance Textual IP4 where+ textual = (<?> "IPv4 address")+ $ ip4FromOctets+ <$> (octet <* PC.char '.')+ <*> (octet <* PC.char '.')+ <*> (octet <* PC.char '.')+ <*> octet+ where octet = (<?> "IPv4 octet") $ do+ o ← nnUpTo Decimal 3+ if o > 255+ then fail "out of bounds"+ else return $ fromIntegral (o ∷ Int)++instance Storable IP4 where+ alignment _ = alignment (undefined ∷ Word32)+ sizeOf _ = 4+ peek p = IP4 . fromBigEndian <$> peek (castPtr p)+ poke p = poke (castPtr p) . toBigEndian . unIP4++-- | The octets of an IPv4 address.+ip4ToOctets ∷ IP4 → (Word8, Word8, Word8, Word8)+ip4ToOctets (IP4 w) = ( fromIntegral $ w `shiftR` 24+ , fromIntegral $ w `shiftR` 16+ , fromIntegral $ w `shiftR` 8+ , fromIntegral w+ )+{-# INLINABLE ip4ToOctets #-}++-- | List the octets of an IPv4 address.+ip4ToOctetList ∷ IP4 → [Word8]+ip4ToOctetList (IP4 w) = fromIntegral <$>+ [w `shiftR` 24, w `shiftR` 16, w `shiftR` 8, w]+{-# INLINABLE ip4ToOctetList #-}++-- | Assemble IPv4 address from the octets.+ip4FromOctets ∷ Word8 → Word8 → Word8 → Word8 → IP4+ip4FromOctets o1 o2 o3 o4 =+ IP4 $ fromIntegral o1 `shiftL` 24+ .|. fromIntegral o2 `shiftL` 16+ .|. fromIntegral o3 `shiftL` 8+ .|. fromIntegral o4+{-# INLINABLE ip4FromOctets #-}++-- | Assemble IPv4 address from the octet list.+ip4FromOctetList ∷ [Word8] → Maybe IP4+ip4FromOctetList [o1, o2, o3, o4] = Just $ ip4FromOctets o1 o2 o3 o4+ip4FromOctetList _ = Nothing+{-# INLINABLE ip4FromOctetList #-}++-- | IPv4 address @0.0.0.0@.+anyIP4 ∷ IP4+anyIP4 = IP4 0+{-# INLINE anyIP4 #-}++instance Default IP4 where+ def = anyIP4+ {-# INLINE def #-}++-- | IPv6 address.+newtype IP6 = IP6 { unIP6 ∷ Word128 }+ deriving (Typeable, Eq, Ord, Bounded, Enum, Ix, Num, Bits, Hashable)++-- | 'IP6' proxy value.+anIP6 ∷ Proxy IP6+anIP6 = Proxy++instance Show IP6 where+ showsPrec p a+ = showParen (p > 10)+ $ showString+ $ printf "ip6FromWords 0x%x 0x%x 0x%x 0x%x 0x%x 0x%x 0x%x 0x%x"+ w1 w2 w3 w4 w5 w6 w7 w8+ where+ (w1, w2, w3, w4, w5, w6, w7, w8) = ip6ToWords a++instance Printable IP6 where+ print addr = case addrZeroes of+ Nothing → P.fsep (P.char7 ':') $ hex <$> addrWords+ Just (i, n) → P.fsep (P.char7 ':') (hex <$> take i addrWords)+ <> P.string7 "::"+ <> P.fsep (P.char7 ':') (hex <$> drop (i + n) addrWords)+ where hex = P.nonNegative LowHex+ addrWords = ip6ToWordList addr+ addrZeroes = go 0 0 0 addrWords+ go !i zi zn = \case+ [] → if zn <= 1 then Nothing else Just (zi, zn)+ (0 : words') → inZeroes (i + 1) zi zn i 1 words'+ (_ : words') → go (i + 1) zi zn words'+ inZeroes !i zi zn zi' !zn' = \case+ [] | zn' <= 1 → if zn <= 1 then Nothing else Just (zi, zn)+ | zn <= 1 → Just (zi', zn')+ | otherwise → Just $ if zn >= zn' then (zi, zn) else (zi', zn')+ (0 : words') → inZeroes (i + 1) zi zn zi' (zn' + 1) words'+ (_ : words') | zn' > zn → go (i + 1) zi' zn' words'+ | otherwise → go (i + 1) zi zn words'++instance Textual IP6 where+ textual = (<?> "IPv6 address") $ optional (PC.char ':') >>= \case+ Just _ → do+ void $ PC.char ':'+ optional word >>= \case+ Just w → after 6 0 (fromIntegral w)+ Nothing → return anyIP6+ Nothing → do+ w ← word+ before 7 (fromIntegral w)+ where + word = nnUpTo Hexadecimal 4 `hintTypeArg` aWord16 <?> "word"+ before 0 w = return $ IP6 w+ before 1 w = do+ void $ PC.char ':'+ optional (PC.char ':') >>= \case+ Just _ →+ return $ IP6 $ w `shiftL` 16+ Nothing → do+ w' ← word+ return $ IP6 $ (w `shiftL` 16) .|. fromIntegral w'+ before upTo w = do+ void $ PC.char ':'+ optional (PC.char ':') >>= \case+ Just _ → optional word >>= \case+ Just w' →+ after (upTo - 2) (w `shiftL` (upTo * 16)) (fromIntegral w')+ Nothing →+ return $ IP6 $ w `shiftL` (upTo * 16)+ Nothing → do+ w' ← word+ before (upTo - 1) ((w `shiftL` 16) .|. fromIntegral w')+ after 0 w1 w2 = return $ IP6 $ w1 .|. w2+ after upTo w1 w2 = optional (PC.char ':') >>= \case+ Just _ → do+ w ← word+ after (upTo - 1) w1 ((w2 `shiftL` 16) .|. fromIntegral w)+ Nothing →+ return $ IP6 $ w1 .|. w2++instance Storable IP6 where+ alignment _ = alignment (undefined ∷ Word64)+ sizeOf _ = 16+ peek p = fmap IP6+ $ fromHiAndLo <$> (fromBigEndian <$> peek (castPtr p))+ <*> (fromBigEndian <$> peek (castPtr p))+ poke p (IP6 w) = do+ poke (castPtr p) $ toBigEndian $ hiWord w+ poke (castPtr p) $ toBigEndian $ loWord w++instance Binary IP6 where+ get = fmap IP6 $ fromHiAndLo <$> B.get <*> B.get+ put (IP6 w) = do+ B.put $ hiWord w+ B.put $ loWord w++instance Serialize IP6 where+ get = fmap IP6 $ fromHiAndLo <$> S.get <*> S.get+ put (IP6 w) = do+ S.put $ hiWord w+ S.put $ loWord w++-- | The 16-bit pieces of an IPv6 address.+ip6ToWords ∷ IP6 → (Word16, Word16, Word16, Word16,+ Word16, Word16, Word16, Word16)+ip6ToWords (IP6 w) =+ ( fromIntegral $ hi `shiftR` 48+ , fromIntegral $ hi `shiftR` 32+ , fromIntegral $ hi `shiftR` 16+ , fromIntegral hi+ , fromIntegral $ lo `shiftR` 48+ , fromIntegral $ lo `shiftR` 32+ , fromIntegral $ lo `shiftR` 16+ , fromIntegral lo+ )+ where hi = hiWord w+ lo = loWord w+{-# INLINABLE ip6ToWords #-}++-- | List the 16-bit pieces of an IPv6 address.+ip6ToWordList ∷ IP6 → [Word16]+ip6ToWordList (IP6 w) = fromIntegral <$>+ [ hi `shiftR` 48+ , hi `shiftR` 32+ , hi `shiftR` 16+ , hi+ , lo `shiftR` 48+ , lo `shiftR` 32+ , lo `shiftR` 16+ , lo+ ]+ where hi = hiWord w+ lo = loWord w+{-# INLINABLE ip6ToWordList #-}++-- | Assemble IPv6 address from the 16-bit pieces.+ip6FromWords ∷ Word16 → Word16 → Word16 → Word16+ → Word16 → Word16 → Word16 → Word16+ → IP6+ip6FromWords w1 w2 w3 w4 w5 w6 w7 w8 = IP6 $ fromHiAndLo hi lo+ where hi = fromIntegral w1 `shiftL` 48+ .|. fromIntegral w2 `shiftL` 32+ .|. fromIntegral w3 `shiftL` 16+ .|. fromIntegral w4+ lo = fromIntegral w5 `shiftL` 48+ .|. fromIntegral w6 `shiftL` 32+ .|. fromIntegral w7 `shiftL` 16+ .|. fromIntegral w8+{-# INLINABLE ip6FromWords #-}++-- | Assemble IPv6 address from the list of 16-bit pieces.+ip6FromWordList ∷ [Word16] → Maybe IP6+ip6FromWordList [w1, w2, w3, w4, w5, w6, w7, w8] =+ Just $ ip6FromWords w1 w2 w3 w4 w5 w6 w7 w8+ip6FromWordList _ = Nothing+{-# INLINABLE ip6FromWordList #-}++-- | IPv6 address @::@.+anyIP6 ∷ IP6+anyIP6 = IP6 0+{-# INLINE anyIP6 #-}++instance Default IP6 where+ def = anyIP6+ {-# INLINE def #-}++-- IP address.+data IP = IPv4 {-# UNPACK #-} !IP4+ | IPv6 {-# UNPACK #-} !IP6+ deriving (Typeable, Eq, Ord, Show)++-- | 'IP' proxy value.+anIP ∷ Proxy IP+anIP = Proxy++instance Printable IP where+ print (IPv4 a) = print a+ print (IPv6 a) = print a+ {-# INLINABLE print #-}++instance Textual IP where+ textual = try (IPv4 <$> textual) <|> (IPv6 <$> textual)+ {-# INLINABLE textual #-}++instance Binary IP where+ get = B.get >>= return . either IPv4 IPv6+ put (IPv4 a) = B.put (Left a ∷ Either IP4 IP6)+ put (IPv6 a) = B.put (Right a ∷ Either IP4 IP6)++instance Serialize IP where+ get = S.get >>= return . either IPv4 IPv6+ put (IPv4 a) = S.put (Left a ∷ Either IP4 IP6)+ put (IPv6 a) = S.put (Right a ∷ Either IP4 IP6)++-- | Network address.+class IsNetAddr n where+ -- | The address type.+ type NetHost n+ -- | Host address.+ netHost ∷ n → NetHost n+ -- | Host index.+ netHostIx ∷ n → NetHost n+ -- | Network prefix.+ netPrefix ∷ n → NetHost n+ -- | Network mask.+ netMask ∷ n → NetHost n+ -- | Network prefix length.+ netLength ∷ n → Word8+ -- | Make a network address.+ netAddr ∷ NetHost n -- ^ Host address+ → Word8 -- ^ Network prefix length+ → n++-- | Network address: host address + network mask length.+data NetAddr a = NetAddr a {-# UNPACK #-} !Word8+ deriving (Typeable, Eq)++type Net4Addr = NetAddr IP4+type Net6Addr = NetAddr IP6++-- | 'NetAddr' proxy value.+aNetAddr ∷ Proxy NetAddr+aNetAddr = Proxy++-- | 'NetAddr' /a/ proxy value.+aNetAddrOf ∷ Proxy a → Proxy (NetAddr a)+aNetAddrOf _ = Proxy++-- | 'Net4Addr' proxy value.+aNet4Addr ∷ Proxy Net4Addr+aNet4Addr = Proxy++-- | 'Net6Addr' proxy value.+aNet6Addr ∷ Proxy Net6Addr+aNet6Addr = Proxy++-- | 'NetAddr' 'IP' proxy value.+aNetAddrIP ∷ Proxy (NetAddr IP)+aNetAddrIP = Proxy++instance Show a ⇒ Show (NetAddr a) where+ showsPrec p (NetAddr a w) = showParen (p > 10)+ $ showString "netAddr "+ . showsPrec 11 a+ . showString " "+ . showsPrec 11 w++instance Printable a ⇒ Printable (NetAddr a) where+ print (NetAddr a m) = print a <> P.char7 '/' <> print m+ {-# INLINE print #-}++instance Textual (NetAddr IP4) where+ textual = net4Parser+ {-# INLINE textual #-}++instance Textual (NetAddr IP6) where+ textual = net6Parser+ {-# INLINE textual #-}++instance Textual (NetAddr IP) where+ textual = netParser+ {-# INLINE textual #-}++instance Binary Net4Addr where+ get = netAddr <$> B.get <*> B.get+ put (NetAddr a w) = B.put a >> B.put w++instance Binary Net6Addr where+ get = netAddr <$> B.get <*> B.get+ put (NetAddr a w) = B.put a >> B.put w++instance Binary (NetAddr IP) where+ get = netAddr <$> B.get <*> B.get+ put (NetAddr a w) = B.put a >> B.put w++instance Serialize Net4Addr where+ get = netAddr <$> S.get <*> S.get+ put (NetAddr a w) = S.put a >> S.put w++instance Serialize Net6Addr where+ get = netAddr <$> S.get <*> S.get+ put (NetAddr a w) = S.put a >> S.put w++instance Serialize (NetAddr IP) where+ get = netAddr <$> S.get <*> S.get+ put (NetAddr a w) = S.put a >> S.put w++instance IsNetAddr Net4Addr where+ type NetHost Net4Addr = IP4+ netHost (NetAddr a _) = a+ {-# INLINE netHost #-}+ netHostIx (NetAddr a w) = (a `shiftL` l) `shiftR` l+ where l = fromIntegral w+ {-# INLINE netHostIx #-}+ netPrefix (NetAddr a w) = (a `shiftR` l) `shiftL` l+ where l = 32 - fromIntegral w+ {-# INLINE netPrefix #-}+ netMask (NetAddr _ w) = IP4 $ (allOnes `shiftR` l) `shiftL` l+ where l = 32 - fromIntegral w+ {-# INLINE netMask #-}+ netLength (NetAddr _ w) = w+ {-# INLINE netLength #-}+ netAddr a w = NetAddr a (w `min` 32)+ {-# INLINE netAddr #-}++instance IsNetAddr Net6Addr where+ type NetHost Net6Addr = IP6+ netHost (NetAddr a _) = a+ {-# INLINE netHost #-}+ netHostIx (NetAddr a w) = (a `shiftL` l) `shiftR` l+ where l = fromIntegral w+ {-# INLINE netHostIx #-}+ netPrefix (NetAddr a w) = (a `shiftR` l) `shiftL` l+ where l = 128 - fromIntegral w+ {-# INLINE netPrefix #-}+ netMask (NetAddr _ w) = IP6 $ (allOnes `shiftR` l) `shiftL` l+ where l = 128 - fromIntegral w+ {-# INLINE netMask #-}+ netLength (NetAddr _ w) = w+ {-# INLINE netLength #-}+ netAddr a w = NetAddr a (w `min` 128)+ {-# INLINE netAddr #-}++instance IsNetAddr (NetAddr IP) where+ type NetHost (NetAddr IP) = IP+ netHost (NetAddr a _) = a+ {-# INLINE netHost #-}+ netHostIx (NetAddr a w) = case a of+ IPv4 a1 → IPv4 $ (a1 `shiftL` l) `shiftR` l+ IPv6 a1 → IPv6 $ (a1 `shiftL` l) `shiftR` l+ where l = fromIntegral w+ {-# INLINABLE netHostIx #-}+ netPrefix (NetAddr a w) = case a of+ IPv4 a1 → IPv4 $ (a1 `shiftR` l) `shiftL` l+ where l = 32 - fromIntegral w+ IPv6 a1 → IPv6 $ (a1 `shiftR` l) `shiftL` l+ where l = 128 - fromIntegral w+ {-# INLINABLE netPrefix #-}+ netMask (NetAddr a w) = case a of+ IPv4 _ → IPv4 $ IP4 $ (allOnes `shiftR` l) `shiftL` l+ where l = 32 - fromIntegral w+ IPv6 _ → IPv6 $ IP6 $ (allOnes `shiftR` l) `shiftL` l+ where l = 128 - fromIntegral w+ {-# INLINABLE netMask #-}+ netLength (NetAddr _ w) = w+ {-# INLINE netLength #-}+ netAddr a w = NetAddr a (w `min` m)+ where m = case a of+ IPv4 _ → 32+ IPv6 _ → 128+ {-# INLINABLE netAddr #-}++-- | Print network address (CIDR notation).+printNetAddr ∷ (IsNetAddr n, Printable (NetHost n), Printer p) ⇒ n → p+printNetAddr n = print (netHost n) <> P.char7 '/' <> print (netLength n)+{-# INLINABLE printNetAddr #-}++ip4Mask ∷ (CharParsing μ, Monad μ) ⇒ μ Word8+ip4Mask = (<?> "network prefix length") $ do+ m ← nncUpTo Decimal 2+ when (m > 32) $ fail "out of bounds"+ return m++-- | IPv4 network address parser (CIDR notation).+net4Parser ∷ (CharParsing μ, Monad μ, IsNetAddr n, NetHost n ~ IP4) ⇒ μ n+net4Parser = netAddr <$> textual <*> (PC.char '/' *> ip4Mask)+ <?> "IPv4 network address"+{-# INLINE net4Parser #-}++ip6Mask ∷ (CharParsing μ, Monad μ) ⇒ μ Word8+ip6Mask = (<?> "network prefix length") $ do+ m ← nncUpTo Decimal 3+ when (m > (128 ∷ Int)) $ fail "out of bounds"+ return $ fromIntegral m++-- | IPv6 network address parser (CIDR notation).+net6Parser ∷ (CharParsing μ, Monad μ, IsNetAddr n, NetHost n ~ IP6) ⇒ μ n+net6Parser = netAddr <$> textual <*> (PC.char '/' *> ip6Mask)+ <?> "IPv6 network address"+{-# INLINE net6Parser #-}++-- | IP network address parser (CIDR notation).+netParser ∷ (IsNetAddr n, NetHost n ~ IP, CharParsing μ, Monad μ) ⇒ μ n+netParser = (<?> "IP network address") $ do+ a ← textual+ void $ PC.char '/'+ m ← mask a+ return $ netAddr a m+ where+ mask (IPv4 _) = ip4Mask+ mask (IPv6 _) = ip6Mask++-- | Port number.+newtype InetPort = InetPort { unInetPort ∷ Word16 }+ deriving (Typeable, Eq, Ord, Bounded, Enum, Ix, Num, Real, Integral, Bits,+ Hashable, Binary, Serialize, Printable)++-- | 'InetPort' proxy value.+anInetPort ∷ Proxy InetPort+anInetPort = Proxy++instance Show InetPort where+ show (InetPort p) = show p+ {-# INLINE show #-}++instance Textual InetPort where+ textual = InetPort <$> nncBounded Decimal <?> "port number"++instance Storable InetPort where+ alignment _ = alignment (undefined ∷ Word16)+ sizeOf _ = 2+ peek p = InetPort . fromBigEndian <$> peek (castPtr p)+ poke p = poke (castPtr p) . toBigEndian . unInetPort++-- | Socket address: host address + port number.+data InetAddr a = InetAddr { inetHost ∷ a+ , inetPort ∷ {-# UNPACK #-} !InetPort+ } deriving (Eq, Ord, Show)++deriving instance Typeable1 InetAddr++type Inet4Addr = InetAddr IP4+type Inet6Addr = InetAddr IP6++-- | 'InetAddr' proxy value.+anInetAddr ∷ Proxy (InetAddr IP)+anInetAddr = Proxy++-- | 'InetAddr' /a/ proxy value.+anInetAddrOf ∷ Proxy a → Proxy (InetAddr a)+anInetAddrOf _ = Proxy++-- | 'Inet4Addr' proxy value.+anInet4Addr ∷ Proxy Inet4Addr+anInet4Addr = Proxy++-- | 'Inet6Addr' proxy value.+anInet6Addr ∷ Proxy Inet6Addr+anInet6Addr = Proxy++-- | 'InetAddr' 'IP' proxy value.+anInetAddrIP ∷ Proxy (InetAddr IP)+anInetAddrIP = Proxy++instance Functor InetAddr where+ fmap f (InetAddr a p) = InetAddr (f a) p+ {-# INLINE fmap #-}++instance Printable Inet4Addr where+ print (InetAddr a p) = print a <> P.char7 ':' <> print p+ {-# INLINABLE print #-}++instance Printable Inet6Addr where+ print (InetAddr a p) = P.brackets (print a) <> P.char7 ':' <> print p+ {-# INLINABLE print #-}++instance Printable (InetAddr IP) where+ print (InetAddr (IPv4 a) p) = print (InetAddr a p)+ print (InetAddr (IPv6 a) p) = print (InetAddr a p)+ {-# INLINABLE print #-}++instance Textual Inet4Addr where+ textual = InetAddr <$> textual <*> (PC.char ':' *> textual)+ <?> "IPv4 socket address"+ {-# INLINE textual #-}++instance Textual Inet6Addr where+ textual = InetAddr <$> (PC.char '[' *> textual <* PC.char ']')+ <*> (PC.char ':' *> textual)+ <?> "IPv6 socket address"+ {-# INLINE textual #-}++instance Textual (InetAddr IP) where+ textual = InetAddr+ <$> (optional (PC.char '[') >>= \case+ Nothing → IPv4 <$> textual+ Just _ → IPv6 <$> textual <* PC.char ']')+ <*> (PC.char ':' *> textual)+ <?> "IP socket address"+ {-# INLINABLE textual #-}++instance Hashable a ⇒ Hashable (InetAddr a) where+#if MIN_VERSION_hashable(1,2,0)+ hashWithSalt s (InetAddr a p) = s `hashWithSalt` a `hashWithSalt` p+ {-# INLINE hashWithSalt #-}+#else+ hash (InetAddr a p) = hash a `combine` hash p+ {-# INLINE hash #-}+#endif++instance Binary a ⇒ Binary (InetAddr a) where+ get = InetAddr <$> B.get <*> B.get+ put (InetAddr a p) = B.put a >> B.put p++instance Serialize a ⇒ Serialize (InetAddr a) where+ get = InetAddr <$> S.get <*> S.get+ put (InetAddr a p) = S.put a >> S.put p+
+ tests/Tests.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck++import Data.DoubleWord+import Data.Textual+import Network.IP.Addr+import Control.Applicative++instance Arbitrary IP4 where+ arbitrary = IP4 <$> arbitrary+ shrink = fmap IP4 . shrink . unIP4++instance Arbitrary IP6 where+ arbitrary = fmap IP6 $ fromHiAndLo <$> arbitrary <*> arbitrary+ shrink = fmap IP6 . shrinkIntegral . unIP6++instance Arbitrary IP where+ arbitrary = oneof [IPv4 <$> arbitrary, IPv6 <$> arbitrary]+ shrink (IPv4 a) = IPv4 <$> shrink a+ shrink (IPv6 a) = IPv6 <$> shrink a++instance Arbitrary Net4Addr where+ arbitrary = netAddr <$> arbitrary <*> suchThat arbitrary (<= 32)+ shrink n = uncurry netAddr <$> shrink (netHost n, netLength n)++instance Arbitrary Net6Addr where+ arbitrary = netAddr <$> arbitrary <*> suchThat arbitrary (<= 128)+ shrink n = uncurry netAddr <$> shrink (netHost n, netLength n)++instance Arbitrary (NetAddr IP) where+ arbitrary = do+ a ← arbitrary+ m ← mask a+ return $ netAddr a m+ where+ mask (IPv4 _) = suchThat arbitrary (<= 32)+ mask (IPv6 _) = suchThat arbitrary (<= 128)+ shrink n = uncurry netAddr <$> shrink (netHost n, netLength n)++instance Arbitrary InetPort where+ arbitrary = InetPort <$> arbitrary+ shrink = fmap InetPort . shrink . unInetPort++instance Arbitrary a ⇒ Arbitrary (InetAddr a) where+ arbitrary = InetAddr <$> arbitrary <*> arbitrary+ shrink n = uncurry InetAddr <$> shrink (inetHost n, inetPort n)++main = defaultMain+ [ testGroup "IP4"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ IP4)+ , testProperty "parsing \"1.2.3.4\"" $+ fromString "1.2.3.4" == Just (IP4 0x01020304)+ , testProperty "parsing \"11.22.33.44\"" $+ fromString "11.22.33.44" == Just (IP4 0x0b16212c)+ , testProperty "parsing \"1.256.3.4\" fails" $+ fromStringAs anIP4 "1.256.3.4" == Nothing+ , testProperty "parsing \" 1.2.3.4\" fails" $+ fromStringAs anIP4 " 1.2.3.4" == Nothing+ , testProperty "parsing \"1.2.3.4 \" fails" $+ fromStringAs anIP4 "1.2.3.4 " == Nothing+ , testProperty "parsing \"1.2. 3.4\" fails" $+ fromStringAs anIP4 "1.2. 3.4 " == Nothing+ , testProperty "parsing \"1.2.3..4\" fails" $+ fromStringAs anIP4 "1.2.3..4" == Nothing+ , testProperty "parsing \"1.2.3.\" fails" $+ fromStringAs anIP4 "1.2.3." == Nothing+ , testProperty "parsing \"1.2.3\" fails" $+ fromStringAs anIP4 "1.2.3" == Nothing+ , testProperty "parsing \"1.2.3.4.5\" fails" $+ fromStringAs anIP4 "1.2.3.4.5" == Nothing+ , testProperty "parsing \"1a.2.3.4\" fails" $+ fromStringAs anIP4 "1a.2.3.4" == Nothing+ ]+ , testGroup "IP6"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ IP6)+ , testProperty "parsing \"::\"" $+ fromString "::" == Just anyIP6+ , testProperty "parsing \":::\" fails" $+ fromStringAs anIP6 ":::" == Nothing+ , testProperty "parsing \" 1::2\" fails" $+ fromStringAs anIP6 " 1::2" == Nothing+ , testProperty "parsing \"1::2 \" fails" $+ fromStringAs anIP6 "1::2 " == Nothing+ , testProperty "parsing \"1: :2\" fails" $+ fromStringAs anIP6 "1: :2" == Nothing+ , testProperty "parsing \"1::2:\" fails" $+ fromStringAs anIP6 "1::2:" == Nothing+ , testProperty "parsing \":1::2\" fails" $+ fromStringAs anIP6 ":1::2" == Nothing+ , testProperty "parsing \"1:abcde::2\" fails" $+ fromStringAs anIP6 "1:abcde::2" == Nothing+ , testProperty "parsing \"1:abcg::2\" fails" $+ fromStringAs anIP6 "1:abcg::2" == Nothing+ , testProperty "parsing \"1:2:3:4a:5:6:7:8\"" $+ fromString "1:2:3:4a:5:6:7:8" ==+ Just (IP6 0x000100020003004a0005000600070008)+ , testProperty "parsing \"1:2:3:4:5bc:6:7::\"" $+ fromString "1:2:3:4:5bc:6:7::" ==+ Just (IP6 0x000100020003000405bc000600070000)+ , testProperty "parsing \"::1:2:3ad9:4:5:6:7\"" $+ fromString "::1:2:3ad9:4:5:6:7" ==+ Just (IP6 0x000100023ad90004000500060007)+ , testProperty "parsing \"1:2:3:4:a5:6::\"" $+ fromString "1:2:3:4:a5:6::" ==+ Just (IP6 0x000100020003000400a5000600000000)+ , testProperty "parsing \"::1:2:3:4:5:6\"" $+ fromString "::1:2:3:4:5:6" ==+ Just (IP6 0x000100020003000400050006)+ , testProperty "parsing \"1::2:3:4:5:6\"" $+ fromString "1::2:3:4:5:6" ==+ Just (IP6 0x00010000000000020003000400050006)+ , testProperty "parsing \"1:2:3::4:5:6\"" $+ fromString "1:2:3::4:5:6" ==+ Just (IP6 0x00010002000300000000000400050006)+ , testProperty "parsing \"1:2:3::4:5::6\" fails" $+ fromStringAs anIP6 "1:2:3::4:5::6" == Nothing+ , testProperty "parsing \"::1:2:3::4:5:6\" fails" $+ fromStringAs anIP6 "::1:2:3::4:5:6" == Nothing+ , testProperty "parsing \"1:2::3:4:5g\" fails" $+ fromStringAs anIP6 "1:2::3:4:5g" == Nothing+ , testProperty "parsing \"1:2:3:4:5:6:7:8g\" fails" $+ fromStringAs anIP6 "1:2:3:4:5:6:7:8g" == Nothing+ ]+ , testGroup "IP"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ IP)+ ]+ , testGroup "Net4Addr"+ [ testProperty "print -> parse" $ \n →+ fromString (toString n) == Just (n ∷ Net4Addr)+ , testProperty "parsing \"11.22.33.44/14\"" $+ case fromStringAs aNet4Addr "11.22.33.44/14" of+ Just n | netHost n == IP4 0x0b16212c+ , netHostIx n == IP4 0x0002212c+ , netPrefix n == IP4 0x0b140000+ , netMask n == IP4 0xfffc0000+ , netLength n == 14+ → True+ _ → False+ , testProperty "parsing \"1.2.3/16\" fails" $+ fromStringAs aNet4Addr "1.2.3/16" == Nothing+ , testProperty "parsing \"1.2 .3.4/16\" fails" $+ fromStringAs aNet4Addr "1.2 .3.4/16" == Nothing+ , testProperty "parsing \"1.2.3.4/ 16\" fails" $+ fromStringAs aNet4Addr "1.2.3.4/ 16" == Nothing+ , testProperty "parsing \"1.2.3.4 / 16\" fails" $+ fromStringAs aNet4Addr "1.2.3.4 / 16" == Nothing+ , testProperty "parsing \"1.2.3.4/16 \" fails" $+ fromStringAs aNet4Addr "1.2.3.4/16 " == Nothing+ , testProperty "parsing \"1.2.3.4/33\" fails" $+ fromStringAs aNet4Addr "1.2.3.4/33" == Nothing+ , testProperty "parsing \"1.2.3.4/012\" fails" $+ fromStringAs aNet4Addr "1.2.3.4/012" == Nothing+ ]+ , testGroup "Net6Addr"+ [ testProperty "print -> parse" $ \n →+ fromString (toString n) == Just (n ∷ Net6Addr)+ , testProperty "parsing \"1234:5678:9abc:def::/22\"" $+ case fromStringAs aNet6Addr "1234:5678:9abc:def::/22" of+ Just n | netHost n == IP6 0x123456789abc0def0000000000000000+ , netHostIx n == IP6 0x000002789abc0def0000000000000000+ , netPrefix n == IP6 0x12345400000000000000000000000000+ , netMask n == IP6 0xfffffc00000000000000000000000000+ , netLength n == 22+ → True+ _ → False+ , testProperty "parsing \"1:2:3/16\" fails" $+ fromStringAs aNet6Addr "1:2:3/16" == Nothing+ , testProperty "parsing \"1:2 :3:4::/16\" fails" $+ fromStringAs aNet6Addr "1:2 :3:4::/16" == Nothing+ , testProperty "parsing \"::1:2:3:4/ 16\" fails" $+ fromStringAs aNet6Addr "::1:2:3:4/ 16" == Nothing+ , testProperty "parsing \"::1:2:3:4 / 16\" fails" $+ fromStringAs aNet6Addr "::1:2:3:4 / 16" == Nothing+ , testProperty "parsing \"::1:2:3:4/16 \" fails" $+ fromStringAs aNet6Addr "::1:2:3:4/16 " == Nothing+ , testProperty "parsing \"::/129\" fails" $+ fromStringAs aNet6Addr "::/129" == Nothing+ , testProperty "parsing \"::/01\" fails" $+ fromStringAs aNet6Addr "::/01" == Nothing+ ]+ , testGroup "NetAddr"+ [ testProperty "print -> parse" $ \n →+ fromString (toString n) == Just (n ∷ NetAddr IP)+ ]+ , testGroup "InetPort"+ [ testProperty "print -> parse" $ \p →+ fromString (toString p) == Just (p ∷ InetPort)+ , testProperty "parsing \"01\" fails" $+ fromStringAs anInetPort "01" == Nothing+ , testProperty "parsing \"123456\" fails" $+ fromStringAs anInetPort "123456" == Nothing+ , testProperty "parsing \"65536\" fails" $+ fromStringAs anInetPort "65536" == Nothing+ ]+ , testGroup "Inet4Addr"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ Inet4Addr)+ , testProperty "parsing \"11.22.33.44:55\"" $+ case fromString "11.22.33.44:55" of+ Just (InetAddr (IP4 0x0b16212c) 55) → True+ _ → False+ ]+ , testGroup "Inet6Addr"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ Inet6Addr)+ , testProperty "parsing \"[1234:5678:9abc:def::]:55\"" $+ case fromString "[1234:5678:9abc:def::]:55" of+ Just (InetAddr (IP6 0x123456789abc0def0000000000000000) 55) → True+ _ → False+ ]+ , testGroup "InetAddr"+ [ testProperty "print -> parse" $ \a →+ fromString (toString a) == Just (a ∷ InetAddr IP)+ ]+ ]+