diff --git a/ip.cabal b/ip.cabal --- a/ip.cabal +++ b/ip.cabal @@ -1,5 +1,5 @@ name: ip -version: 1.1.2 +version: 1.2.0 synopsis: Library for IP and MAC addresses homepage: https://github.com/andrewthad/haskell-ip#readme license: BSD3 @@ -47,7 +47,7 @@ Data.Text.Builder.Common.Internal Data.ByteString.Builder.Fixed build-depends: - base >= 4.8 && < 5 + base >= 4.9 && < 5 , attoparsec >= 0.13 && < 0.14 , aeson >= 0.9 && < 1.3 , hashable >= 1.2 && < 1.3 @@ -55,6 +55,7 @@ , 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 @@ -70,7 +71,7 @@ , test-framework , test-framework-quickcheck2 , QuickCheck - , quickcheck-classes >= 0.3 && < 0.4 + , quickcheck-classes >= 0.3 && < 0.5 , text , bytestring , HUnit @@ -81,6 +82,21 @@ IPv4Text1 IPv4Text2 IPv4ByteString1 + ghc-options: -Wall -O2 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , ip + , hspec + , hspec >= 2.4.4 && < 2.5 + other-modules: + Net.IPv4Spec + Net.IPv4.RangeSpec ghc-options: -Wall -O2 default-language: Haskell2010 diff --git a/src/Data/ByteString/Builder/Fixed.hs b/src/Data/ByteString/Builder/Fixed.hs --- a/src/Data/ByteString/Builder/Fixed.hs +++ b/src/Data/ByteString/Builder/Fixed.hs @@ -31,6 +31,7 @@ import Data.ByteString.Internal (ByteString(..)) import Foreign import Data.ByteString.Short (ShortByteString) +import qualified Data.Semigroup as Semigroup import qualified Data.ByteString.Internal as BI import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as BC8 @@ -40,17 +41,25 @@ BuilderStatic :: !ByteString -> Builder a BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a +{-# INLINE appendBuilder #-} +appendBuilder :: Builder a -> Builder a -> Builder a +appendBuilder x y = case x of + BuilderStatic t1@(PS _ _ len1) -> case y of + BuilderStatic t2 -> BuilderStatic (t1 <> t2) + BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) + BuilderFunction t1@(PS _ _ len1) f1 -> case y of + BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 + BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + +instance Semigroup.Semigroup (Builder a) where + {-# INLINE (<>) #-} + (<>) = appendBuilder + instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = BuilderStatic ByteString.empty {-# INLINE mappend #-} - mappend x y = case x of - BuilderStatic t1@(PS _ _ len1) -> case y of - BuilderStatic t2 -> BuilderStatic (t1 <> t2) - BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) - BuilderFunction t1@(PS _ _ len1) f1 -> case y of - BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 - BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + mappend = (Semigroup.<>) contramapBuilder :: (b -> a) -> Builder a -> Builder b contramapBuilder f x = case x of diff --git a/src/Data/Text/Builder/Fixed.hs b/src/Data/Text/Builder/Fixed.hs --- a/src/Data/Text/Builder/Fixed.hs +++ b/src/Data/Text/Builder/Fixed.hs @@ -28,6 +28,7 @@ import Data.Char (ord) import Data.Word.Synthetic.Word12 (Word12) import Data.Text (Text) +import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.Array as A import qualified Data.Text.Internal as TI @@ -37,21 +38,29 @@ BuilderStatic :: Text -> Builder a BuilderFunction :: Text -> (forall s. Int -> A.MArray s -> a -> ST s ()) -> Builder a +{-# INLINE appendBuilder #-} +appendBuilder :: Builder a -> Builder a -> Builder a +appendBuilder x y = case x of + BuilderStatic t1 -> case y of + BuilderStatic t2 -> BuilderStatic (t1 <> t2) + BuilderFunction t2 f -> + let len1 = I.portableTextLength t1 + in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) + BuilderFunction t1 f1 -> case y of + BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 + BuilderFunction t2 f2 -> + let len1 = I.portableTextLength t1 + in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + +instance Semigroup.Semigroup (Builder a) where + {-# INLINE (<>) #-} + (<>) = appendBuilder + instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = BuilderStatic Text.empty {-# INLINE mappend #-} - mappend x y = case x of - BuilderStatic t1 -> case y of - BuilderStatic t2 -> BuilderStatic (t1 <> t2) - BuilderFunction t2 f -> - let len1 = I.portableTextLength t1 - in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) - BuilderFunction t1 f1 -> case y of - BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 - BuilderFunction t2 f2 -> - let len1 = I.portableTextLength t1 - in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + mappend = (Semigroup.<>) fromText :: Text -> Builder a fromText = BuilderStatic diff --git a/src/Data/Text/Builder/Variable.hs b/src/Data/Text/Builder/Variable.hs --- a/src/Data/Text/Builder/Variable.hs +++ b/src/Data/Text/Builder/Variable.hs @@ -29,6 +29,7 @@ import Data.Vector (Vector) import Data.Maybe (fromMaybe) import qualified Data.Vector as Vector +import qualified Data.Semigroup as Semigroup import qualified Data.Text.Array as A import qualified Data.Text.Builder.Common.Internal as I import qualified Data.Text.Internal as TI @@ -38,14 +39,22 @@ {-# UNPACK #-} !Int -- the maximum length, not a character count !(forall s. Int -> A.MArray s -> a -> ST s Int) +{-# INLINE appendBuilder #-} +appendBuilder :: Builder a -> Builder a -> Builder a +appendBuilder (Builder len1 f) (Builder len2 g) = + Builder (len1 + len2) $ \ix1 marr a -> do + ix2 <- f ix1 marr a + g ix2 marr a + +instance Semigroup.Semigroup (Builder a) where + {-# INLINE (<>) #-} + (<>) = appendBuilder + instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = Builder 0 (\i _ _ -> return i) {-# INLINE mappend #-} - mappend (Builder len1 f) (Builder len2 g) = - Builder (len1 + len2) $ \ix1 marr a -> do - ix2 <- f ix1 marr a - g ix2 marr a + mappend = (Semigroup.<>) run :: Builder a -> a -> Text run (Builder maxLen f) = \a -> diff --git a/src/Net/IPv4.hs b/src/Net/IPv4.hs --- a/src/Net/IPv4.hs +++ b/src/Net/IPv4.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} @@ -41,7 +42,7 @@ , decode , builder , reader - , parser + , parser -- ** UTF-8 ByteString , encodeUtf8 , decodeUtf8 @@ -55,6 +56,8 @@ , print -- * Types , IPv4(..) + -- * Interoperability + -- $interoperability ) where import Prelude hiding (any, print) @@ -72,12 +75,12 @@ import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8') import Foreign.Storable (Storable) -import Data.Bits (Bits,FiniteBits) import Data.Primitive.Types (Prim) import Control.Monad.ST (ST,runST) import Text.Printf (printf) import Text.Read (Read(..),Lexeme(Ident),lexP,parens) import Text.ParserCombinators.ReadPrec (prec,step) +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 @@ -99,7 +102,7 @@ import qualified Data.Text.Array as TArray import qualified Data.Text.IO as TIO -#if MIN_VERSION_aeson(1,0,0) +#if MIN_VERSION_aeson(1,0,0) import Data.Aeson (ToJSONKey(..),FromJSONKey(..), ToJSONKeyFunction(..),FromJSONKeyFunction(..)) #endif @@ -154,7 +157,7 @@ any :: IPv4 any = IPv4 0 --- | The loopback IP address: @127.0.0.1@ +-- | The local loopback IP address: @127.0.0.1@ loopback :: IPv4 loopback = fromOctets 127 0 0 1 @@ -311,7 +314,7 @@ else return i {- $string - + These functions exist for the convenience of those who need a 'String' representation of an 'IPv4' address. Using them is discouraged unless the end user is working with a library @@ -332,7 +335,7 @@ -- convert the underlying 'Word32' from host byte order to network byte -- order. newtype IPv4 = IPv4 { getIPv4 :: Word32 } - deriving (Eq,Ord,Enum,Bounded,Hashable,Generic,Prim,Bits,FiniteBits,Storable) + deriving (Eq,Ord,Enum,Bounded,Hashable,Generic,Prim,Storable) instance Show IPv4 where showsPrec p addr = showParen (p > 10) @@ -355,7 +358,7 @@ c <- step readPrec d <- step readPrec return (fromOctets a b c d) - + print :: IPv4 -> IO () print = TIO.putStrLn . encode @@ -412,7 +415,7 @@ instance FromJSON IPv4 where parseJSON = Aeson.withText "IPv4" aesonParser -#if MIN_VERSION_aeson(1,0,0) +#if MIN_VERSION_aeson(1,0,0) instance ToJSONKey IPv4 where toJSONKey = ToJSONKeyText encode @@ -427,7 +430,28 @@ Nothing -> fail "Could not parse IPv4 address" Just addr -> return addr +ipv4Bitwise :: (Word32 -> Word32 -> Word32) -> IPv4 -> IPv4 -> IPv4 +ipv4Bitwise fun l r = IPv4 $ (getIPv4 l) `fun` (getIPv4 r) +-- | Note: we use network order (big endian) as opposed to host order (little +-- endian) which differs from the underlying IPv4 type representation. +instance Bits.Bits IPv4 where + (.&.) = ipv4Bitwise (.&.) + (.|.) = ipv4Bitwise (.|.) + xor = ipv4Bitwise Bits.xor + complement = IPv4 . Bits.complement . getIPv4 + shift ip i = IPv4 $ Bits.shift (getIPv4 ip) i + rotate ip i = IPv4 $ Bits.rotate (getIPv4 ip) i + bitSize = Bits.finiteBitSize + bitSizeMaybe = Bits.bitSizeMaybe . getIPv4 + isSigned = Bits.isSigned . getIPv4 + testBit ip i = Bits.testBit (getIPv4 ip) $ Bits.finiteBitSize ip - 1 - i + bit i = IPv4 $ Bits.bit $ Bits.finiteBitSize any - 1 - i + popCount = Bits.popCount . getIPv4 + +instance Bits.FiniteBits IPv4 where + finiteBitSize = Bits.finiteBitSize . getIPv4 + ------------------------------------ -- Internal functions, not exported ------------------------------------ @@ -587,4 +611,26 @@ rightToMaybe :: Either a b -> Maybe b rightToMaybe = either (const Nothing) Just + +{- $interoperability + +The @@ library is commonly +used to open sockets and communicate over them. In the @Network.Socket@ module, +it provides a type synonym @HostAddress@ that, like 'IPv4', is used +to represent an IPv4 address. However, while 'IPv4' uses a big-endian representation +for ip addresses, @HostAddress@ has platform dependent endianness. +Consequently, it is necessary to convert between the two as follows: + +> import Network.Socket (HostAddress,htonl,ntohl) +> +> toHostAddr :: IPv4 -> HostAddress +> toHostAddr (IPv4 w) = htonl w +> +> fromHostAddr :: HostAddress -> IPv4 +> fromHostAddr w = IPv4 (ntohl w) + +These functions are not included with this library since it would require +picking up a dependency on @network@. + +-} diff --git a/src/Net/IPv4/Range.hs b/src/Net/IPv4/Range.hs --- a/src/Net/IPv4/Range.hs +++ b/src/Net/IPv4/Range.hs @@ -43,6 +43,7 @@ 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 @@ -163,12 +164,12 @@ -- 192.168.1.11 toList :: IPv4Range -> [IPv4] -toList (IPv4Range ip len) = +toList (IPv4Range ip len) = let totalAddrs = countAddrs len in wordSuccessors totalAddrs ip toGenerator :: MonadPlus m => IPv4Range -> m IPv4 -toGenerator (IPv4Range ip len) = +toGenerator (IPv4Range ip len) = let totalAddrs = countAddrs len in wordSuccessorsM totalAddrs ip @@ -365,6 +366,47 @@ 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 diff --git a/test/Net/IPv4/RangeSpec.hs b/test/Net/IPv4/RangeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Net/IPv4/RangeSpec.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +module Net.IPv4.RangeSpec (spec) where +import Prelude hiding (any) +import Data.Bits +import Net.IPv4 +import Net.IPv4.Range +import Test.Hspec + +spec :: Spec +spec = parallel $ do + describe "Bits" $ do + context "underlying IPv4 imlementation used correctly" $ do + let host = range (ipv4 255 255 0 0) 32 + broadH = range broadcast 32 + negBroadH = range (ipv4 0 0 255 255) 32 + it ".&." $ do + host .&. broadH `shouldBe` host + it ".|." $ do + host .|. broadH `shouldBe` broadH + it "xor" $ do + host `xor` broadH `shouldBe` negBroadH + it "complement" $ do + complement host `shouldBe` negBroadH + it "shift" $ do + shift host 8 `shouldBe` range (ipv4 255 0 0 0) 32 + it "rotate" $ do + rotate host 8 `shouldBe` range (ipv4 255 0 0 255) 32 + it "isSigned" $ do + isSigned host `shouldBe` False + context "size operations use length correctly" $ do + it "bitSize" $ do + bitSize (range any 8) `shouldBe` 8 + bitSize (range any 15) `shouldBe` 15 + bitSize (range any 32) `shouldBe` 32 + it "bitSizeMaybe" $ do + bitSizeMaybe (range broadcast 0) `shouldBe` Just 0 + bitSizeMaybe (range broadcast 24) `shouldBe` Just 24 + bitSizeMaybe (range broadcast 31) `shouldBe` Just 31 + it "testBit" $ do + let prefix = range loopback 8 + testBit prefix <$> [0..31] `shouldBe` + -- Note: final bit is False not True + [ False, True, True, True, True, True, True, True + , False, False, False, False, False, False, False, False + , False, False, False, False, False, False, False, False + , False, False, False, False, False, False, False, False] + it "bit" $ do + bit 0 `shouldBe` range (ipv4 128 0 0 0) 1 + bit 1 `shouldBe` range (ipv4 64 0 0 0) 2 + bit 31 `shouldBe` range (ipv4 0 0 0 1) 32 + it "popCount" $ do + popCount (range any 0) `shouldBe` 0 + popCount (range broadcast 0) `shouldBe` 0 + popCount (range loopback 8) `shouldBe` 7 + popCount (range loopback 32) `shouldBe` 8 + context "operates on network bits only" $ do + it "bitwise: same length" $ do + (IPv4Range broadcast 16) .&. (IPv4Range broadcast 16) + `shouldBe` (IPv4Range (ipv4 255 255 0 0) 16) + it "bitwise: differing lengths ignoring host bits" $ do + (IPv4Range broadcast 8) .&. (IPv4Range broadcast 16) + `shouldBe` (IPv4Range (ipv4 255 0 0 0) 16) + it "rebase: ignores host bits" $ do + complement (IPv4Range loopback 16) + `shouldBe` (IPv4Range (ipv4 128 255 0 0) 16) + describe "FiniteBits" $ do + it "finiteBitSize" $ do + finiteBitSize . (range loopback) <$> [0..31] `shouldBe` [0..31] diff --git a/test/Net/IPv4Spec.hs b/test/Net/IPv4Spec.hs new file mode 100644 --- /dev/null +++ b/test/Net/IPv4Spec.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +module Net.IPv4Spec (spec) where +import Prelude hiding (any) +import Data.Bits +import Net.IPv4 +import Test.Hspec + +spec :: Spec +spec = do + describe "Bits" $ do + it ".&." $ do + any .&. any `shouldBe` any + any .&. loopback `shouldBe` any + loopback .&. broadcast `shouldBe` loopback + broadcast .&. broadcast `shouldBe` broadcast + it ".|." $ do + any .|. any `shouldBe` any + any .|. loopback `shouldBe` loopback + loopback .|. broadcast `shouldBe` broadcast + broadcast .|. broadcast `shouldBe` broadcast + it "xor" $ do + any `xor` any `shouldBe` any + any `xor` loopback `shouldBe` loopback + loopback `xor` broadcast `shouldBe` complement loopback + broadcast `xor` broadcast `shouldBe` any + it "complement" $ do + complement any `shouldBe` broadcast + complement loopback `shouldBe` ipv4 128 255 255 254 + complement broadcast `shouldBe` any + it "shift" $ do + shift any 0 `shouldBe` any + shift broadcast 0 `shouldBe` broadcast + shift broadcast 8 `shouldBe` ipv4 255 255 255 0 + shift broadcast (-8) `shouldBe` ipv4 0 255 255 255 + shift broadcast 32 `shouldBe` any + shift broadcast 40 `shouldBe` any + it "rotate" $ do + rotate loopback 0 `shouldBe` loopback + rotate loopback 0 `shouldBe` loopback + rotate loopback 8 `shouldBe` ipv4 0 0 1 127 + rotate loopback (-8) `shouldBe` ipv4 1 127 0 0 + rotate loopback 32 `shouldBe` loopback + it "bitSize" $ do + bitSize any `shouldBe` 32 + it "bitSizeMaybe" $ do + bitSizeMaybe any `shouldBe` Just 32 + it "isSigned" $ do + isSigned any `shouldBe` False + isSigned broadcast `shouldBe` False + it "testBit" $ do + testBit loopback <$> [0..31] `shouldBe` + [ False, True, True, True, True, True, True, True + , False, False, False, False, False, False, False, False + , False, False, False, False, False, False, False, False + , False, False, False, False, False, False, False, True] + it "bit" $ do + bit 0 `shouldBe` ipv4 128 0 0 0 + bit 1 `shouldBe` ipv4 64 0 0 0 + bit 31 `shouldBe` ipv4 0 0 0 1 + it "popCount" $ do + popCount any `shouldBe` 0 + popCount loopback `shouldBe` 8 + popCount broadcast `shouldBe` 32 + describe "FiniteBits" $ do + it "finiteBitSize" $ do + finiteBitSize any `shouldBe` 32 + finiteBitSize loopback `shouldBe` 32 + finiteBitSize broadcast `shouldBe` 32 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -14,7 +14,7 @@ import Numeric (showHex) import Test.QuickCheck.Property (failed,succeeded,Result(..)) import Data.Bifunctor -import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws) +import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws,bitsLaws) import qualified Test.Framework.Providers.HUnit as PH import Net.Types (IP,IPv4(..),IPv4Range(..),Mac(..),IPv6(..),MacGrouping(..),MacCodec(..)) @@ -99,10 +99,12 @@ [ testGroup "IPv4" [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4)) , lawsToTest (showReadLaws (Proxy :: Proxy IPv4)) + -- , lawsToTest (bitsLaws (Proxy :: Proxy IPv4)) ] , testGroup "IPv4Range" [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4Range)) , lawsToTest (showReadLaws (Proxy :: Proxy IPv4Range)) + -- , lawsToTest (bitsLaws (Proxy :: Proxy IPv4Range)) ] , testGroup "IPv6" [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6))