ip 1.5.1 → 1.7.8
raw patch · 26 files changed
Files
- CHANGELOG.md +102/−0
- README.md +25/−0
- Setup.hs +0/−2
- ip.cabal +96/−86
- src/Data/ByteString/Builder/Fixed.hs +29/−24
- src/Data/Text/Builder/Common/Compat.hs +14/−0
- src/Data/Text/Builder/Common/Internal.hs +36/−24
- src/Data/Text/Builder/Fixed.hs +17/−12
- src/Data/Text/Builder/Variable.hs +36/−28
- src/Data/Word/Synthetic/Word12.hs +132/−114
- src/Net/IP.hs +176/−84
- src/Net/IPv4.hs +1447/−1110
- src/Net/IPv6.hs +1075/−566
- src/Net/Mac.hs +557/−355
- src/Net/Types.hs +13/−15
- test/Bench.hs +100/−49
- test/Doctests.hs +0/−14
- test/IPv4ByteString1.hs +40/−35
- test/IPv4DecodeText1.hs +19/−18
- test/IPv4DecodeText2.hs +19/−18
- test/IPv4Text1.hs +43/−32
- test/IPv4Text2.hs +13/−14
- test/Naive.hs +18/−16
- test/Net/IPv4/RangeSpec.hs +0/−67
- test/Net/IPv4Spec.hs +91/−60
- test/Test.hs +487/−252
+ CHANGELOG.md view
@@ -0,0 +1,102 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 1.7.8 -- 2024-03-01++* Update package metadata.+* Relaxed upper bounds on dependencies.++## 1.7.7 -- 2023-08-24++* Add `isSubsetOf` for `IPv4` and `IPv6` ranges.++## 1.7.6 -- 2022-10-07++* Bump upper bound on `text` to `< 2.1`.+* Add `Hashable` instances for `IP` and `IPv6`.++## 1.7.5 -- 2022-07-28++* Add `boundedBuilderOctetsBE` and `boundedBuilderOctetsLE` to `Net.IPv4`.+* Make doctests work again. Requires `doctest-0.20` or higher.+* Bump upper bound on `attoparsec` to `< 0.15`.+* Bump upper bound on `hashable` to `< 1.5`.+* Derive `Generic` for `Net.IPv6.IPv6`.+* Bump lower bound on `wide-word` to `>= 0.1.1.2`.+* Add compatibility with GHC 9.2.3.++## 1.7.4 -- 2021-12-28++* Add `decodeUtf8Bytes` to `Net.IP`.+* Fix IPv4 octet overflow bug (#74)++## 1.7.3 -- 2021-01-22++* Export `decodeOctets` from `Net.Mac`.+* Add `encodeShort` to `Net.Mac`.++## 1.7.2 -- 2020-05-30+* Fix bug in `doctest` documentation+* Bump upper bound on `aeson`: (< 1.5) -> (< 1.6)++## 1.7.1 -- 2020-01-22+* Deprecate 'decodeBytes' in favor of 'decodeOctets'.+* Add `Bytes`-oriented encode and decode functions to `Net.Mac`:+ `boundedBuilderUtf8`, `decodeUtf8Bytes`, and `parserUtf8Bytes`.+* Add `parserRangeUtf8Bytes` and `parserRangeUtf8BytesLenient` to+ both `Net.IPv4` and `Net.IPv6` modules.++## 1.7.0 -- 2019-11-05+* Add `Data` instances for all types.+* Add `Ix` instances for all address types.+* Add missing `ToJSON`/`FromJSON` instances for `IPv6Range`.+* Remove `Num`, `Integral`, and `Real` instances from `IPv6`.+* Remove `Bits` instance for `IPv4Range`.+* Switch to derived `Bits` instance for `IPv4.+* Remove old spec test for IPv4 Bits laws, instead use+ quickcheck-classes.+* Bump exclusive upper bound on small-bytearray-builder++## 1.6.0 -- 2019-09-30+* Provide decode functions for decoding from `ShortText` and+ from `Bytes`. These two are implemented internally using+ the same function.+* Dependency on `bytesmith` effectively restricts users to+ GHC 8.6 and up. Since GHC 8.8 is about to be released,+ this is deemed an acceptable cost.+* Require cabal version 2.2 so that leading commas are accepted+ in dependencies lists.++## 1.5.1 -- 2019-07-29+* Allow building with primitive-0.7.+* Add more doctests to Net.IP.+* Add to Net.IP: `isIPv4` and `isIPv6`.+* Bump lower bound on primitive from 0.6 to 0.6.4.+* Bump upper bound on hashable from < 1.3. to < 1.4.++## 1.5.0 -- 2019-03-23+* Implement `IPv6` using `wide-word`'s `Word128`. (This is a breaking change.)++## 1.4.2.1 -- 2019-03-18+* Docfix for `Net.IPv4.toList`++## 1.4.2 -- 2019-03-14+* Fix existing `spec` test suite.+* 100% haddock coverage, along with significantly more doctest coverage.+* Add `Net.IPv4.localhost` and `Net.IPv6.localhost`, aliases for `loopback`.++## 1.4.1 -- 2018-08-19+* Add `Enum` and `Bounded` instances for `Mac`.+* Add `NFData` instances for all types.++## 1.4.0 -- 2018-07-18+* Combine `Net.IPv4` and `Net.IPv4.Range` modules.+* Add `IPv6Range`.+* Drop support for older aeson.+* Add `Enum` instance for `IPv6`.++## 1.2.1 -- 2018-05-10+* Added a `Prim` instance for `Mac`.
+ README.md view
@@ -0,0 +1,25 @@+[](https://hackage.haskell.org/package/ip)++# Instructions++Look at the [haddocks](http://hackage.haskell.org/package/ip) for this +package to learn how to use it.++# Contributing++Most contributions are welcome, especially performance improvements in encoding and decoding of Text/ByteString.+Please make sure to follow naming conventions followed in the modules.++## Doctest++Doctest used to be provided as a test suite, but `doctest-0.20` and higher+do not require this to be run. To run the doctests, make sure you have+`doctest` on your path (i.e. run `cabal install doctest`), and then run:++ cabal build+ cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options='-fno-warn-orphans'++This runs incredibly slowly, but it works for now. Doctest is not run by CI,+so if you make a change that adds more doctests, it needs to be run by hand+by someone. (The maintainer is happy to do this if you're on a platform+where doctest is finicky.)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
ip.cabal view
@@ -1,15 +1,16 @@-cabal-version: 2.0-name: ip-version: 1.5.1-synopsis: Library for IP and MAC addresses-homepage: https://github.com/andrewthad/haskell-ip#readme-license: BSD3-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2016 Andrew Martin-category: web-build-type: Simple+cabal-version: 3.0+name: ip+version: 1.7.8+synopsis: Library for IP and MAC addresses+homepage: https://github.com/byteverse/haskell-ip+bug-reports: https://github.com/byteverse/haskell-ip/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: amartin@layer3com.com+copyright: 2016 Andrew Martin+category: web+build-type: Simple description: The `ip` package provides types and functions for dealing with IPv4 addresses, CIDR blocks, and MAC addresses. We provide instances@@ -29,111 +30,120 @@ The following packages are intended to be used with this package: . * `yesod-ip`: Provides orphan instances needed to work with yesod and- persistent. Also, provides a `yesod-form` helper.+ persistent. Also, provides a `yesod-form` helper. +extra-doc-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1++common build-settings+ default-language: Haskell2010+ ghc-options: -Wall -Wunused-packages+ library- hs-source-dirs: src+ import: build-settings+ hs-source-dirs: src+ ghc-options: -O2 exposed-modules:- Net.Mac+ Net.IP Net.IPv4 Net.IPv6- Net.IP+ Net.Mac Net.Types+ other-modules:- Data.Word.Synthetic.Word12+ Data.ByteString.Builder.Fixed+ Data.Text.Builder.Common.Compat+ Data.Text.Builder.Common.Internal Data.Text.Builder.Fixed Data.Text.Builder.Variable- Data.Text.Builder.Common.Internal- Data.ByteString.Builder.Fixed+ Data.Word.Synthetic.Word12+ build-depends:- base >= 4.9.1.0 && < 5- , aeson >= 1.0 && < 1.5- , attoparsec >= 0.13 && < 0.14- , bytestring >= 0.10 && < 0.11- , deepseq >= 1.4 && < 1.5- , hashable >= 1.2 && < 1.4- , primitive >= 0.6.4 && < 0.8- , text >= 1.2 && < 1.3- , vector >= 0.11 && < 0.13- , wide-word >= 0.1.0.8 && < 0.2- ghc-options: -Wall -O2- default-language: Haskell2010+ , aeson >=1.0+ , attoparsec >=0.13+ , base >=4.9 && <5+ , bytebuild >=0.3.4+ , byteslice >=0.1.2+ , bytesmith >=0.3.9+ , bytestring >=0.10.8+ , deepseq >=1.4+ , hashable >=1.2+ , natural-arithmetic >=0.1+ , primitive >=0.6.4+ , text >=1.2+ , text-short >=0.1.3+ , vector >=0.11+ , wide-word >=0.1.1.2+ , word-compat >=0.0.4 test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Test.hs+ import: build-settings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs build-depends:- base+ , attoparsec+ , base+ , byteslice+ , bytestring+ , HUnit , ip- , wide-word- , test-framework- , test-framework-quickcheck2 , QuickCheck- , quickcheck-classes >= 0.4.13 && < 0.7.0.0+ , quickcheck-classes >=0.4.13 && <0.7.0.0+ , tasty+ , tasty-hunit+ , tasty-quickcheck , text- , bytestring- , HUnit- , test-framework-hunit- , attoparsec+ , text-short+ , wide-word+ other-modules:- Naive+ IPv4ByteString1 IPv4Text1 IPv4Text2- IPv4ByteString1- ghc-options: -Wall -O2- default-language: Haskell2010+ Naive test-suite spec- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs+ import: build-settings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs build-depends:- base+ , base+ , hspec >=2.5.5 , ip- , wide-word- , hspec >= 2.5.5- other-modules:- Net.IPv4Spec- Net.IPv4.RangeSpec- ghc-options: -Wall -O2- default-language: Haskell2010- build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 -test-suite doctest- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Doctests.hs- build-depends:- base- , ip- , wide-word- , doctest >= 0.10- , QuickCheck- default-language: Haskell2010+ other-modules: Net.IPv4Spec+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 benchmark criterion- type: exitcode-stdio-1.0+ import: build-settings+ hs-source-dirs: test+ main-is: Bench.hs+ ghc-options: -O2+ type: exitcode-stdio-1.0 build-depends:- base- , ip+ , attoparsec+ , base+ , byteslice+ , bytestring , criterion+ , ip+ , primitive+ , random , text- , bytestring- , attoparsec+ other-modules:- Naive- IPv4Text1- IPv4Text2+ IPv4ByteString1 IPv4DecodeText1 IPv4DecodeText2- IPv4ByteString1- ghc-options: -Wall -O2- default-language: Haskell2010- hs-source-dirs: test- main-is: Bench.hs+ IPv4Text1+ IPv4Text2+ Naive source-repository head- type: git- location: https://github.com/andrewthad/haskell-ip-+ type: git+ location: git://github.com/byteverse/haskell-ip.git
src/Data/ByteString/Builder/Fixed.hs view
@@ -1,12 +1,12 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}-+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -funbox-strict-fields #-} -{-| For concatenating fixed-width strings that are only a few+{- | For concatenating fixed-width strings that are only a few characters each, this can be six times faster than the builder that ships with @bytestring@. -}@@ -26,19 +26,21 @@ #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif-import Data.Word-import Data.Word.Synthetic.Word12 (Word12) import Data.Bits+import Data.ByteString.Internal (ByteString (..))+import Data.ByteString.Short (ShortByteString) import Data.Char (ord)-import Text.Printf-import Data.ByteString.Internal (ByteString(..))+import Data.Word+import Data.Word.Synthetic.Word12 (Word12) import Foreign-import Data.ByteString.Short (ShortByteString)-import qualified Data.Semigroup as Semigroup-import qualified Data.ByteString.Internal as BI+import Text.Printf+ import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Short.Internal as SBS+import qualified Data.Primitive as PM+import qualified Data.Semigroup as Semigroup data Builder a where BuilderStatic :: !ByteString -> Builder a@@ -74,6 +76,10 @@ fromByteString = BuilderStatic {-# INLINE fromByteString #-} +unsafeIndexShortByteString :: ShortByteString -> Int -> Word8+unsafeIndexShortByteString (SBS.SBS x) i = PM.indexByteArray (PM.ByteArray x) i+{-# INLINE unsafeIndexShortByteString #-}+ run :: Builder a -> a -> ByteString run x a = case x of BuilderStatic t -> t@@ -87,9 +93,9 @@ let !wInt = fromIntegral w !ix = wInt + wInt + wInt !arr = if upper then hexValuesWord12Upper else hexValuesWord12Lower- pokeByteOff marr i (SBS.unsafeIndex arr ix)- pokeByteOff marr (i + 1) (SBS.unsafeIndex arr (ix + 1))- pokeByteOff marr (i + 2) (SBS.unsafeIndex arr (ix + 2))+ pokeByteOff marr i (unsafeIndexShortByteString arr ix)+ pokeByteOff marr (i + 1) (unsafeIndexShortByteString arr (ix + 1))+ pokeByteOff marr (i + 2) (unsafeIndexShortByteString arr (ix + 2)) {-# INLINE word12HexFixedGeneral #-} word12HexFixedUpper :: Builder Word12@@ -102,12 +108,12 @@ hexValuesWord12Upper :: ShortByteString hexValuesWord12Upper =- SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03X") [0 :: Int ..4095]+ SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03X") [0 :: Int .. 4095] {-# NOINLINE hexValuesWord12Upper #-} hexValuesWord12Lower :: ShortByteString hexValuesWord12Lower =- SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03x") [0 :: Int ..4095]+ SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03x") [0 :: Int .. 4095] {-# NOINLINE hexValuesWord12Lower #-} word8HexFixedUpper :: Builder Word8@@ -124,18 +130,18 @@ let !ix = unsafeShiftL (fromIntegral w) 1 !ix2 = ix + 1 !arr = if upper then hexValuesWord8Upper else hexValuesWord8Lower- pokeByteOff marr i (SBS.unsafeIndex arr ix)- pokeByteOff marr (i + 1) (SBS.unsafeIndex arr ix2)+ pokeByteOff marr i (unsafeIndexShortByteString arr ix)+ pokeByteOff marr (i + 1) (unsafeIndexShortByteString arr ix2) {-# INLINE word8HexFixedGeneral #-} hexValuesWord8Upper :: ShortByteString hexValuesWord8Upper =- SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02X") [0 :: Int ..255]+ SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02X") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Upper #-} hexValuesWord8Lower :: ShortByteString hexValuesWord8Lower =- SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02x") [0 :: Int ..255]+ SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02x") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Lower #-} char8 :: Builder Char@@ -146,8 +152,9 @@ word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w {-# INLINE word8 #-} --- | Taken from @Data.ByteString.Internal@. The same warnings--- apply here.+{- | Taken from @Data.ByteString.Internal@. The same warnings+ apply here.+-} c2w :: Char -> Word8 c2w = fromIntegral . ord {-# INLINE c2w #-}@@ -165,5 +172,3 @@ -- <> contramapBuilder (word8At 8) twoDigitWord8Hex -- <> BuilderStatic ":" -- <> contramapBuilder (word8At 0) twoDigitWord8Hex--
+ src/Data/Text/Builder/Common/Compat.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}++{- | Compatibility module allowing us to support UTF-16 & UTF-8 versions of+the 'text' package.+-}+module Data.Text.Builder.Common.Compat (Codepoint) where++import Data.Word++#if MIN_VERSION_text(2, 0, 0)+type Codepoint = Word8+#else+type Codepoint = Word16+#endif
src/Data/Text/Builder/Common/Internal.hs view
@@ -1,29 +1,31 @@ module Data.Text.Builder.Common.Internal where -import Data.Text (Text) import Control.Monad.ST-import Data.Monoid-import Text.Printf import Data.Char (ord) import Data.Foldable (fold)+import Data.Monoid+import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Array as A import qualified Data.Text.Internal.Unsafe.Char as TC+import Text.Printf --- | This is slower that just pattern matching on the Text data constructor.--- However, it will work with GHCJS. This should only be used in places--- where we know that it will only be evaluated once.+{- | This is slower that just pattern matching on the Text data constructor.+ However, it will work with GHCJS. This should only be used in places+ where we know that it will only be evaluated once.+-} portableTextArray :: Text -> A.Array portableTextArray = fst . portableUntext {-# INLINE portableTextArray #-} --- | This length is not the character length. It is the length of Word16s--- required by a UTF16 representation.+{- | This length is not the character length. It is the length of Word16s+ required by a UTF16 representation.+-} portableTextLength :: Text -> Int portableTextLength = snd . portableUntext {-# INLINE portableTextLength #-} -portableUntext :: Text -> (A.Array,Int)+portableUntext :: Text -> (A.Array, Int) portableUntext t = let str = Text.unpack t Sum len = foldMap (Sum . charUtf16Size) str@@ -31,11 +33,12 @@ marr <- A.new len writeString marr str return marr- in (arr,len)+ in (arr, len) {-# NOINLINE portableUntext #-} writeString :: A.MArray s -> String -> ST s ()-writeString marr = go 0 where+writeString marr = go 0+ where go i s = case s of c : cs -> do n <- TC.unsafeWrite marr i c@@ -46,32 +49,41 @@ charUtf16Size c = if ord c < 0x10000 then 1 else 2 hexValuesWord12Upper :: A.Array-hexValuesWord12Upper = portableTextArray $ fold- $ map (Text.pack . printf "%03X") [0 :: Int ..4096]+hexValuesWord12Upper =+ portableTextArray $+ fold $+ map (Text.pack . printf "%03X") [0 :: Int .. 4096] {-# NOINLINE hexValuesWord12Upper #-} hexValuesWord12Lower :: A.Array-hexValuesWord12Lower = portableTextArray $ fold- $ map (Text.pack . printf "%03x") [0 :: Int ..4096]+hexValuesWord12Lower =+ portableTextArray $+ fold $+ map (Text.pack . printf "%03x") [0 :: Int .. 4096] {-# NOINLINE hexValuesWord12Lower #-} hexValuesWord8Upper :: A.Array-hexValuesWord8Upper = portableTextArray $ fold- $ map (Text.pack . printf "%02X") [0 :: Int ..255]+hexValuesWord8Upper =+ portableTextArray $+ fold $+ map (Text.pack . printf "%02X") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Upper #-} hexValuesWord8Lower :: A.Array-hexValuesWord8Lower = portableTextArray $ fold- $ map (Text.pack . printf "%02x") [0 :: Int ..255]+hexValuesWord8Lower =+ portableTextArray $+ fold $+ map (Text.pack . printf "%02x") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Lower #-} twoDecimalDigits :: A.Array-twoDecimalDigits = portableTextArray- $ foldMap (Text.pack . printf "%02d") [0 :: Int ..99]+twoDecimalDigits =+ portableTextArray $+ foldMap (Text.pack . printf "%02d") [0 :: Int .. 99] {-# NOINLINE twoDecimalDigits #-} threeDecimalDigits :: A.Array-threeDecimalDigits = portableTextArray- $ foldMap (Text.pack . printf "%03d") [0 :: Int ..255]+threeDecimalDigits =+ portableTextArray $+ foldMap (Text.pack . printf "%03d") [0 :: Int .. 255] {-# NOINLINE threeDecimalDigits #-}-
src/Data/Text/Builder/Fixed.hs view
@@ -1,12 +1,11 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}-+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -funbox-strict-fields #-} -{-| For concatenating fixed-width strings that are only a few+{- | For concatenating fixed-width strings that are only a few characters each, this can be ten times faster than the builder that ships with @text@. -}@@ -26,16 +25,16 @@ #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif-import Data.Word import Data.Bits import Data.Char (ord)-import Data.Word.Synthetic.Word12 (Word12)-import Data.Text (Text) import qualified Data.Semigroup as Semigroup+import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Array as A-import qualified Data.Text.Internal as TI import qualified Data.Text.Builder.Common.Internal as I+import qualified Data.Text.Internal as TI+import Data.Word+import Data.Word.Synthetic.Word12 (Word12) data Builder a where BuilderStatic :: Text -> Builder a@@ -75,6 +74,7 @@ BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b)) {-# INLINE contramapBuilder #-} +{- FOURMOLU_DISABLE -} run :: Builder a -> a -> Text run x = case x of BuilderStatic t -> \_ -> t@@ -83,11 +83,16 @@ in \a -> let outArr = runST $ do marr <- A.new len+#if MIN_VERSION_text(2, 0, 0)+ A.copyI len marr 0 inArr 0+#else A.copyI marr 0 inArr 0 len+#endif f 0 marr a A.unsafeFreeze marr in TI.text outArr 0 len {-# INLINE run #-}+{- FOURMOLU_ENABLE -} word8HexFixedUpper :: Builder Word8 word8HexFixedUpper = word8HexFixedGeneral True@@ -108,9 +113,10 @@ A.unsafeWrite marr (i + 1) (A.unsafeIndex arr ix2) {-# INLINE word8HexFixedGeneral #-} --- | Characters outside the basic multilingual plane are not handled--- correctly by this function. They will not cause a program to crash;--- instead, the character will have the upper bits masked out.+{- | Characters outside the basic multilingual plane are not handled+ correctly by this function. They will not cause a program to crash;+ instead, the character will have the upper bits masked out.+-} charBmp :: Builder Char charBmp = BuilderFunction (Text.pack "-") $ \i marr c -> A.unsafeWrite marr i (fromIntegral (ord c))@@ -134,4 +140,3 @@ word12HexFixedLower :: Builder Word12 word12HexFixedLower = word12HexFixedGeneral False {-# INLINE word12HexFixedLower #-}-
src/Data/Text/Builder/Variable.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-} -{-| This is a builder optimized for concatenating short+{- | This is a builder optimized for concatenating short variable-length strings whose length has a known upper bound. In these cases, this can be up to ten times faster than the builder provided by the @text@ library. However,@@ -22,17 +23,18 @@ , word8 ) where -import Data.Word-import Data.Text (Text) import Control.Monad.ST import Data.Char (ord)-import Data.Vector (Vector) import Data.Maybe (fromMaybe)-import qualified Data.Vector as Vector import qualified Data.Semigroup as Semigroup+import Data.Text (Text) import qualified Data.Text.Array as A+import Data.Text.Builder.Common.Compat (Codepoint) import qualified Data.Text.Builder.Common.Internal as I import qualified Data.Text.Internal as TI+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.Word data Builder a = Builder@@ -58,10 +60,10 @@ run :: Builder a -> a -> Text run (Builder maxLen f) = \a ->- let (outArr,len) = A.run2 $ do+ let (outArr, len) = A.run2 $ do marr <- A.new maxLen finalIx <- f 0 marr a- return (marr,finalIx)+ return (marr, finalIx) in TI.text outArr 0 len {-# INLINE run #-} @@ -88,25 +90,27 @@ {-# INLINE staticCharBmp #-} word8 :: Builder Word8-word8 = Builder 3 $ \pos marr w -> if- | w < 10 -> do- A.unsafeWrite marr pos (i2w w)- return (pos + 1)- | w < 100 -> do- let wInt = fromIntegral w- ix = wInt + wInt- A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix)- A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1))- return (pos + 2)- | otherwise -> do- let wInt = fromIntegral w- ix = wInt + wInt + wInt- A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix)- A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1))- A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2))- return (pos + 3)+word8 = Builder 3 $ \pos marr w ->+ if+ | w < 10 -> do+ A.unsafeWrite marr pos (i2w w)+ return (pos + 1)+ | w < 100 -> do+ let wInt = fromIntegral w+ ix = wInt + wInt+ A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix)+ A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1))+ return (pos + 2)+ | otherwise -> do+ let wInt = fromIntegral w+ ix = wInt + wInt + wInt+ A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix)+ A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1))+ A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2))+ return (pos + 3) {-# INLINE word8 #-} +{- FOURMOLU_DISABLE -} -- This has not yet been tested. _vector :: Text -- ^ Default, used when index is out of range@@ -120,15 +124,19 @@ $ \_ marr i -> do let (arr,len) = fromMaybe xDef (xs Vector.!? i) finalIx = i + len+#if MIN_VERSION_text(2, 0, 0)+ A.copyI finalIx marr i arr 0+#else A.copyI marr i arr 0 finalIx+#endif return finalIx {-# INLINE _vector #-} -i2w :: Integral a => a -> Word16+i2w :: Integral a => a -> Codepoint i2w v = asciiZero + fromIntegral v {-# INLINE i2w #-}+{- FOURMOLU_ENABLE -} -asciiZero :: Word16+asciiZero :: Codepoint asciiZero = 48 {-# INLINE asciiZero #-}-
src/Data/Word/Synthetic/Word12.hs view
@@ -1,51 +1,56 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NoImplicitPrelude #-} ---- |--- Module : Data.Word.Word12--- License : see src/Data/LICENSE--- Stability : experimental--- Portability : non-portable (GHC Extensions)- -- Provide a 12-bit unsigned integral type: 'Word12', analagous to Word8, -- Word16, etc. -- -module Data.Word.Synthetic.Word12 (- -- * Word12 type- Word12(..)- -- * Internal helpers+{- |+Module : Data.Word.Word12+License : see src/Data/LICENSE+Stability : experimental+Portability : non-portable (GHC Extensions)+-}+module Data.Word.Synthetic.Word12+ ( -- * Word12 type+ Word12 (..)++ -- * Internal helpers , narrow12Word# , clz12# , ctz12# , popCnt12# )- where -import Data.Bits-import Data.Data-import Data.Maybe+import Data.Bits+import Data.Data+import Data.Maybe -import GHC.Arr-import GHC.Base-import GHC.Enum+import GHC.Arr+import GHC.Base+import GHC.Enum+#if MIN_VERSION_base(4,15,0)+import GHC.Integer (integerToWord, smallInteger)+import GHC.Num hiding (integerToWord)+#else import GHC.Num-import GHC.Read-import GHC.Real-import GHC.Show-import GHC.Word+#endif+import GHC.Read+import GHC.Real+import GHC.Show +import qualified GHC.Word.Compat as Compat+ ------------------------------------------------------------------------ -- Word12 is represented in the same way as Word. Operations may assume and -- must ensure that it holds only values in its logical range. -- | 12-bit unsigned integer type--- data Word12 = W12# Word# deriving (Eq, Ord) word12Type :: DataType@@ -54,9 +59,12 @@ instance Data Word12 where toConstr x = mkIntegralConstr word12Type x gunfold _ z c = case constrRep c of- (IntConstr x) -> z (fromIntegral x)- _ -> error $ "Data.Data.gunfold: Constructor " ++ show c- ++ " is not of type Word12."+ (IntConstr x) -> z (fromIntegral x)+ _ ->+ error $+ "Data.Data.gunfold: Constructor "+ ++ show c+ ++ " is not of type Word12." dataTypeOf _ = word12Type -- | narrowings represented as primop 'and#' in GHC.@@ -64,17 +72,14 @@ narrow12Word# = and# 0xFFF## -- | count leading zeros--- clz12# :: Word# -> Word# clz12# w# = clz32# (narrow12Word# w#) `minusWord#` 20## -- | count trailing zeros--- ctz12# :: Word# -> Word# ctz12# w# = ctz# w# -- | the number of set bits--- popCnt12# :: Word# -> Word# popCnt12# w# = popCnt# (narrow12Word# w#) @@ -85,134 +90,147 @@ (W12# x#) + (W12# y#) = W12# (narrow12Word# (x# `plusWord#` y#)) (W12# x#) - (W12# y#) = W12# (narrow12Word# (x# `minusWord#` y#)) (W12# x#) * (W12# y#) = W12# (narrow12Word# (x# `timesWord#` y#))- negate (W12# x#) = W12# (narrow12Word# (int2Word# (negateInt# (word2Int# x#))))- abs x = x- signum 0 = 0- signum _ = 1- fromInteger i = W12# (narrow12Word# (integerToWord i))+ negate (W12# x#) = W12# (narrow12Word# (int2Word# (negateInt# (word2Int# x#))))+ abs x = x+ signum 0 = 0+ signum _ = 1+ fromInteger i = W12# (narrow12Word# (integerToWord i)) instance Real Word12 where toRational x = toInteger x % 1 instance Enum Word12 where succ x- | x /= maxBound = x + 1- | otherwise = succError "Word12"+ | x /= maxBound = x + 1+ | otherwise = succError "Word12" pred x- | x /= minBound = x - 1- | otherwise = predError "Word12"+ | x /= minBound = x - 1+ | otherwise = predError "Word12" toEnum i@(I# i#)- | i >= 0 && i <= fromIntegral (maxBound :: Word12)- = W12# (int2Word# i#)- | otherwise = toEnumError "Word12" i (minBound::Word12, maxBound::Word12)+ | i >= 0 && i <= fromIntegral (maxBound :: Word12) =+ W12# (int2Word# i#)+ | otherwise = toEnumError "Word12" i (minBound :: Word12, maxBound :: Word12) fromEnum (W12# x#) = I# (word2Int# x#)- enumFrom = boundedEnumFrom- enumFromThen = boundedEnumFromThen+ enumFrom = boundedEnumFrom+ enumFromThen = boundedEnumFromThen instance Integral Word12 where quot (W12# x#) y@(W12# y#)- | y /= 0 = W12# (x# `quotWord#` y#)- | otherwise = divZeroError+ | y /= 0 = W12# (x# `quotWord#` y#)+ | otherwise = divZeroError rem (W12# x#) y@(W12# y#)- | y /= 0 = W12# (x# `remWord#` y#)- | otherwise = divZeroError+ | y /= 0 = W12# (x# `remWord#` y#)+ | otherwise = divZeroError div (W12# x#) y@(W12# y#)- | y /= 0 = W12# (x# `quotWord#` y#)- | otherwise = divZeroError+ | y /= 0 = W12# (x# `quotWord#` y#)+ | otherwise = divZeroError mod (W12# x#) y@(W12# y#)- | y /= 0 = W12# (x# `remWord#` y#)- | otherwise = divZeroError+ | y /= 0 = W12# (x# `remWord#` y#)+ | otherwise = divZeroError quotRem (W12# x#) y@(W12# y#)- | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))- | otherwise = divZeroError+ | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))+ | otherwise = divZeroError divMod (W12# x#) y@(W12# y#)- | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))- | otherwise = divZeroError- toInteger (W12# x#) = smallInteger (word2Int# x#)+ | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))+ | otherwise = divZeroError+ toInteger (W12# x#) = smallInteger (word2Int# x#) instance Bounded Word12 where minBound = 0 maxBound = 0xFFFFFF instance Ix Word12 where- range (m,n) = [m..n]- unsafeIndex (m,_) i = fromIntegral (i - m)- inRange (m,n) i = m <= i && i <= n+ range (m, n) = [m .. n]+ unsafeIndex (m, _) i = fromIntegral (i - m)+ inRange (m, n) i = m <= i && i <= n instance Read Word12 where- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]+ readsPrec p s = [(fromIntegral (x :: Int), r) | (x, r) <- readsPrec p s] instance Bits Word12 where- {-# INLINE shift #-}- {-# INLINE bit #-}- {-# INLINE testBit #-}+ {-# INLINE shift #-}+ {-# INLINE bit #-}+ {-# INLINE testBit #-} - (W12# x#) .&. (W12# y#) = W12# (x# `and#` y#)- (W12# x#) .|. (W12# y#) = W12# (x# `or#` y#)- (W12# x#) `xor` (W12# y#) = W12# (x# `xor#` y#)- complement (W12# x#) = W12# (x# `xor#` mb#) where !(W12# mb#) = maxBound- (W12# x#) `shift` (I# i#)- | isTrue# (i# >=# 0#) = W12# (narrow12Word# (x# `shiftL#` i#))- | otherwise = W12# (x# `shiftRL#` negateInt# i#)- (W12# x#) `shiftL` (I# i#) = W12# (narrow12Word# (x# `shiftL#` i#))- (W12# x#) `unsafeShiftL` (I# i#) =- W12# (narrow12Word# (x# `uncheckedShiftL#` i#))- (W12# x#) `shiftR` (I# i#) = W12# (x# `shiftRL#` i#)- (W12# x#) `unsafeShiftR` (I# i#) = W12# (x# `uncheckedShiftRL#` i#)- (W12# x#) `rotate` i- | isTrue# (i'# ==# 0#) = W12# x#- | otherwise = W12# (narrow12Word# ((x# `uncheckedShiftL#` i'#) `or#`- (x# `uncheckedShiftRL#` (12# -# i'#))))- where- !(I# i'#) = i `mod` 12- bitSizeMaybe i = Just (finiteBitSize i)- bitSize = finiteBitSize- isSigned _ = False- popCount (W12# x#) = I# (word2Int# (popCnt12# x#))- bit = bitDefault- testBit = testBitDefault+ (W12# x#) .&. (W12# y#) = W12# (x# `and#` y#)+ (W12# x#) .|. (W12# y#) = W12# (x# `or#` y#)+ (W12# x#) `xor` (W12# y#) = W12# (x# `xor#` y#)+ complement (W12# x#) = W12# (x# `xor#` mb#) where !(W12# mb#) = maxBound+ (W12# x#) `shift` (I# i#)+ | isTrue# (i# >=# 0#) = W12# (narrow12Word# (x# `shiftL#` i#))+ | otherwise = W12# (x# `shiftRL#` negateInt# i#)+ (W12# x#) `shiftL` (I# i#) = W12# (narrow12Word# (x# `shiftL#` i#))+ (W12# x#) `unsafeShiftL` (I# i#) =+ W12# (narrow12Word# (x# `uncheckedShiftL#` i#))+ (W12# x#) `shiftR` (I# i#) = W12# (x# `shiftRL#` i#)+ (W12# x#) `unsafeShiftR` (I# i#) = W12# (x# `uncheckedShiftRL#` i#)+ (W12# x#) `rotate` i+ | isTrue# (i'# ==# 0#) = W12# x#+ | otherwise =+ W12#+ ( narrow12Word#+ ( (x# `uncheckedShiftL#` i'#)+ `or#` (x# `uncheckedShiftRL#` (12# -# i'#))+ )+ )+ where+ !(I# i'#) = i `mod` 12+ bitSizeMaybe i = Just (finiteBitSize i)+ bitSize = finiteBitSize+ isSigned _ = False+ popCount (W12# x#) = I# (word2Int# (popCnt12# x#))+ bit = bitDefault+ testBit = testBitDefault instance FiniteBits Word12 where- finiteBitSize _ = 12- countLeadingZeros (W12# x#) = I# (word2Int# (clz12# x#))- countTrailingZeros (W12# x#) = I# (word2Int# (ctz12# x#))+ finiteBitSize _ = 12+ countLeadingZeros (W12# x#) = I# (word2Int# (clz12# x#))+ countTrailingZeros (W12# x#) = I# (word2Int# (ctz12# x#)) {-# RULES-"fromIntegral/Word8->Word12" fromIntegral = \(W8# x#) -> W12# x#-"fromIntegral/Word12->Word12" fromIntegral = id :: Word12 -> Word12-"fromIntegral/Word12->Integer" fromIntegral = toInteger :: Word12 -> Integer-"fromIntegral/a->Word12" fromIntegral = \x -> case fromIntegral x of W# x# -> W12# (narrow12Word# x#)-"fromIntegral/Word12->a" fromIntegral = \(W12# x#) -> fromIntegral (W# x#)+"fromIntegral/Word8->Word12" fromIntegral = \x -> case x of Compat.W8# y -> W12# y+"fromIntegral/Word12->Word12" fromIntegral = id :: Word12 -> Word12+"fromIntegral/Word12->Integer" fromIntegral = toInteger :: Word12 -> Integer+"fromIntegral/a->Word12" fromIntegral = \x -> case fromIntegral x of W# x# -> W12# (narrow12Word# x#)+"fromIntegral/Word12->a" fromIntegral = \(W12# x#) -> fromIntegral (W# x#) #-} {-# RULES "properFraction/Float->(Word12,Float)"- properFraction = \x ->- case properFraction x of {- (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Float) }+ properFraction =+ \x ->+ case properFraction x of+ (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Float) "truncate/Float->Word12"- truncate = (fromIntegral :: Int -> Word12) . (truncate :: Float -> Int)+ truncate =+ (fromIntegral :: Int -> Word12) . (truncate :: Float -> Int) "floor/Float->Word12"- floor = (fromIntegral :: Int -> Word12) . (floor :: Float -> Int)+ floor =+ (fromIntegral :: Int -> Word12) . (floor :: Float -> Int) "ceiling/Float->Word12"- ceiling = (fromIntegral :: Int -> Word12) . (ceiling :: Float -> Int)+ ceiling =+ (fromIntegral :: Int -> Word12) . (ceiling :: Float -> Int) "round/Float->Word12"- round = (fromIntegral :: Int -> Word12) . (round :: Float -> Int)+ round =+ (fromIntegral :: Int -> Word12) . (round :: Float -> Int) #-} {-# RULES "properFraction/Double->(Word12,Double)"- properFraction = \x ->- case properFraction x of {- (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Double) }+ properFraction =+ \x ->+ case properFraction x of+ (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Double) "truncate/Double->Word12"- truncate = (fromIntegral :: Int -> Word12) . (truncate :: Double -> Int)+ truncate =+ (fromIntegral :: Int -> Word12) . (truncate :: Double -> Int) "floor/Double->Word12"- floor = (fromIntegral :: Int -> Word12) . (floor :: Double -> Int)+ floor =+ (fromIntegral :: Int -> Word12) . (floor :: Double -> Int) "ceiling/Double->Word12"- ceiling = (fromIntegral :: Int -> Word12) . (ceiling :: Double -> Int)+ ceiling =+ (fromIntegral :: Int -> Word12) . (ceiling :: Double -> Int) "round/Double->Word12"- round = (fromIntegral :: Int -> Word12) . (round :: Double -> Int)+ round =+ (fromIntegral :: Int -> Word12) . (round :: Double -> Int) #-}--
src/Net/IP.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall #-} -{-| An IP data type representing either an IPv4 address or+{- | An IP data type representing either an IPv4 address or an IPv6 address. The user can think of this as though it were a sum type. However, to minimize indirections, it is actually implemented as an 'IPv6' address, with 'IPv4'@@ -25,74 +29,108 @@ >>> decode "A3F5:12:F26::1466:8B91" Just (ipv6 0xa3f5 0x0012 0x0f26 0x0000 0x0000 0x0000 0x1466 0x8b91) -}- module Net.IP ( -- * Pattern Matching case_ , isIPv4 , isIPv6+ -- * Construction , ipv4 , ipv6 , fromIPv4 , fromIPv6+ -- * Textual Conversion+ -- ** Text , encode+ , encodeShort , decode+ , decodeShort+ , boundedBuilderUtf8++ -- ** Bytes+ , decodeUtf8Bytes+ , parserUtf8Bytes+ -- ** Printing , print+ -- * Types- , IP(..)+ , IP (..) ) where import Control.DeepSeq (NFData)-import Data.Aeson (FromJSON(..),ToJSON(..))+import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bits+import Data.Coerce (coerce)+import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.Ix (Ix) import Data.Text (Text)-import Data.WideWord (Word128(..))-import Data.Word (Word8,Word16)+import Data.Text.Short (ShortText)+import Data.WideWord (Word128 (..))+import Data.Word (Word16, Word8) import GHC.Generics (Generic)-import Net.IPv4 (IPv4(..))-import Net.IPv6 (IPv6(..))-import Prelude hiding (print)+import Net.IPv4 (IPv4 (..))+import Net.IPv6 (IPv6 (..)) import Text.ParserCombinators.ReadPrec ((+++))-import Text.Read (Read(..))+import Text.Read (Read (..))+import Prelude hiding (print)++import qualified Arithmetic.Lte as Lte import qualified Data.Aeson as Aeson+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Builder.Bounded as BB+import qualified Data.Bytes.Parser as Parser import qualified Data.Text.IO as TIO import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 --- $setup--- >>> :set -XOverloadedStrings+{- $setup+>>> :set -XOverloadedStrings+>>> import qualified Arithmetic.Nat as Nat+-} --- | Run a function over an 'IP' depending on its status--- as an 'IPv4' or 'IPv6'.------ >>> case_ IPv4.encode IPv6.encode (ipv4 192 168 2 47)--- "192.168.2.47"------ >>> addr = ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001--- >>> case_ IPv4.encode IPv6.encode addr--- "2001:db8::1"+{- | Run a function over an 'IP' depending on its status+ as an 'IPv4' or 'IPv6'.++ >>> case_ IPv4.encode IPv6.encode (ipv4 192 168 2 47)+ "192.168.2.47"++ >>> addr = ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001+ >>> case_ IPv4.encode IPv6.encode addr+ "2001:db8::1"+-} case_ :: (IPv4 -> a) -> (IPv6 -> a) -> IP -> a -- Note: rather than performing the masking operations on the 'Word128', -- we unwrap the 'Word64's, as that's probably a bit more efficient, and -- we might need the lower word anyway.-case_ f g (IP addr@(IPv6 (Word128 w1 w2))) = if w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000)- then f (IPv4 (fromIntegral w2))- else g addr+case_ f g (IP addr@(IPv6 (Word128 w1 w2))) =+ if w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000)+ then f (IPv4 (fromIntegral w2))+ else g addr --- | Construct an 'IP' address from the four octets of--- an IPv4 address.+{- | Construct an 'IP' address from the four octets of+ an IPv4 address.+-} ipv4 :: Word8 -> Word8 -> Word8 -> Word8 -> IP ipv4 a b c d = fromIPv4 (IPv4.fromOctets a b c d) --- | Construct an 'IP' address from the eight 16-bit--- chunks of an IPv6 address.-ipv6 :: Word16 -> Word16 -> Word16 -> Word16- -> Word16 -> Word16 -> Word16 -> Word16- -> IP+{- | Construct an 'IP' address from the eight 16-bit+ chunks of an IPv6 address.+-}+ipv6 ::+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ IP ipv6 a b c d e f g h = fromIPv6 (IPv6.fromWord16s a b c d e f g h) -- | Turn an 'IPv4' into an 'IP'.@@ -103,29 +141,53 @@ fromIPv6 :: IPv6 -> IP fromIPv6 = IP --- | Encode an 'IP' as 'Text'.------ >>> encode (ipv4 10 0 0 25)--- "10.0.0.25"------ >>> encode (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)--- "3124::dead:cafe:ff:fe00:1"+{- | Encode an 'IP' as 'Text'.++ >>> encode (ipv4 10 0 0 25)+ "10.0.0.25"++ >>> encode (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)+ "3124::dead:cafe:ff:fe00:1"+-} encode :: IP -> Text encode = case_ IPv4.encode IPv6.encode --- | Decode an 'IP' from 'Text'.------ >>> decode "10.0.0.25"--- Just (ipv4 10 0 0 25)------ >>> fmap isIPv4 (decode "10.0.0.25")--- Just True------ >>> decode "3124::dead:cafe:ff:fe00:1"--- Just (ipv6 0x3124 0x0000 0x0000 0xdead 0xcafe 0x00ff 0xfe00 0x0001)------ >>> fmap isIPv6 (decode "3124::dead:cafe:ff:fe00:1")--- Just True+{- | Encode an 'IP' as 'ShortText'.++ >>> encodeShort (ipv4 10 0 1 26)+ "10.0.1.26"++ >>> encodeShort (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE01 0x0000)+ "3124::dead:cafe:ff:fe01:0"+-}+encodeShort :: IP -> ShortText+encodeShort = case_ IPv4.encodeShort IPv6.encodeShort++{- | Encode an 'IP' as a bounded bytearray builder.++>>> BB.run Nat.constant (boundedBuilderUtf8 (ipv4 192 168 2 14))+[0x31, 0x39, 0x32, 0x2e, 0x31, 0x36, 0x38, 0x2e, 0x32, 0x2e, 0x31, 0x34]+-}+boundedBuilderUtf8 :: IP -> BB.Builder 39+boundedBuilderUtf8 =+ case_+ (\y -> BB.weaken Lte.constant (IPv4.boundedBuilderUtf8 y))+ IPv6.boundedBuilderUtf8++{- | Decode an 'IP' from 'Text'.++ >>> decode "10.0.0.25"+ Just (ipv4 10 0 0 25)++ >>> fmap isIPv4 (decode "10.0.0.25")+ Just True++ >>> decode "3124::dead:cafe:ff:fe00:1"+ Just (ipv6 0x3124 0x0000 0x0000 0xdead 0xcafe 0x00ff 0xfe00 0x0001)++ >>> fmap isIPv6 (decode "3124::dead:cafe:ff:fe00:1")+ Just True+-} decode :: Text -> Maybe IP decode t = case IPv4.decode t of Nothing -> case IPv6.decode t of@@ -133,46 +195,77 @@ Just v6 -> Just (fromIPv6 v6) Just v4 -> Just (fromIPv4 v4) --- | Is the 'IP' an IPv4 address?------ >>> isIPv4 (ipv4 10 0 0 25)--- True------ >>> isIPv4 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)--- False+{- | Decode an 'IP' from 'ShortText'.++ >>> decodeShort "10.0.0.25"+ Just (ipv4 10 0 0 25)+ >>> decodeShort "::dead:cafe"+ Just (ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0xdead 0xcafe)+-}+decodeShort :: ShortText -> Maybe IP+decodeShort t+ | Just x <- IPv4.decodeShort t = Just (fromIPv4 x)+ | otherwise = coerce (IPv6.decodeShort t)++-- | Decode UTF-8-encoded 'Bytes' into an 'IP' address.+decodeUtf8Bytes :: Bytes.Bytes -> Maybe IP+decodeUtf8Bytes !b = case Parser.parseBytes (parserUtf8Bytes ()) b of+ Parser.Success (Parser.Slice _ len addr) -> case len of+ 0 -> Just addr+ _ -> Nothing+ Parser.Failure _ -> Nothing++-- | Parse UTF-8-encoded 'Bytes' as an 'IP' address.+parserUtf8Bytes :: e -> Parser.Parser e s IP+parserUtf8Bytes e =+ fmap fromIPv4 (IPv4.parserUtf8Bytes ())+ `Parser.orElse` coerce (IPv6.parserUtf8Bytes e)++{- | Is the 'IP' an IPv4 address?++ >>> isIPv4 (ipv4 10 0 0 25)+ True++ >>> isIPv4 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)+ False+-} isIPv4 :: IP -> Bool isIPv4 = case_ (const True) (const False)-{-# inline isIPv4 #-}+{-# INLINE isIPv4 #-} --- | Is the 'IP' an IPv6 address?------ >>> isIPv6 (ipv4 10 0 0 25)--- False------ >>> isIPv6 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)--- True+{- | Is the 'IP' an IPv6 address?++ >>> isIPv6 (ipv4 10 0 0 25)+ False++ >>> isIPv6 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)+ True+-} isIPv6 :: IP -> Bool isIPv6 = case_ (const False) (const True)-{-# inline isIPv6 #-}+{-# INLINE isIPv6 #-} --- | Print an 'IP' using the textual encoding. This exists mostly for--- debugging purposes.------ >>> print (ipv4 10 0 0 25)--- 10.0.0.25------ >>> print (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)--- 3124::dead:cafe:ff:fe00:1+{- | Print an 'IP' using the textual encoding. This exists mostly for+ debugging purposes.++ >>> print (ipv4 10 0 0 25)+ 10.0.0.25++ >>> print (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1)+ 3124::dead:cafe:ff:fe00:1+-} print :: IP -> IO () print = TIO.putStrLn . encode --- | A 32-bit 'IPv4' address or a 128-bit 'IPv6' address. Internally, this--- is just represented as an 'IPv6' address. The functions provided--- in @Net.IP@ help simulate constructing and pattern matching on values--- of this type. All functions and typeclass methods that convert--- 'IP' values to text will display it as an 'IPv4' address if possible.-newtype IP = IP { getIP :: IPv6 }- deriving (Eq,Ord,Generic)+{- | A 32-bit 'IPv4' address or a 128-bit 'IPv6' address. Internally, this+ is just represented as an 'IPv6' address. The functions provided+ in @Net.IP@ help simulate constructing and pattern matching on values+ of this type. All functions and typeclass methods that convert+ 'IP' values to text will display it as an 'IPv4' address if possible.+-}+newtype IP = IP {getIP :: IPv6}+ deriving stock (Eq, Ord, Generic, Ix, Data)+ deriving newtype (Hashable) instance NFData IP @@ -189,4 +282,3 @@ parseJSON = Aeson.withText "IP" $ \t -> case decode t of Nothing -> fail "Could not parse IP address" Just addr -> return addr-
src/Net/IPv4.hs view
@@ -1,1112 +1,1449 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE UnboxedTuples #-}--{-| This module provides the IPv4 data type and functions for working- with it.--}--module Net.IPv4- ( -- * Conversion Functions- ipv4- , fromOctets- , fromTupleOctets- , toOctets- -- * Special IP Addresses- , any- , loopback- , localhost- , broadcast- -- * Range Predicates- , private- , reserved- , public- -- * Textual Conversion- -- ** Text- , encode- , decode- , builder- , reader- , parser- -- ** UTF-8 ByteString- , encodeUtf8- , decodeUtf8- , builderUtf8- , parserUtf8- -- ** String- -- $string- , encodeString- , 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 Control.DeepSeq (NFData)-import Control.Monad-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.Hashable-import Data.Monoid ((<>))-import Data.Primitive.Types (Prim)-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 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.ByteString.Builder as Builder-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Internal as I-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.Primitive as PVector-import qualified Data.Vector.Unboxed as UVector-import qualified Data.Vector.Unboxed.Mutable as MUVector---- $setup------ These are here to get doctest's property checking to work------ >>> :set -XOverloadedStrings--- >>> import Test.QuickCheck (Arbitrary(..))--- >>> 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--- significant. Since IP addresses are commonly written using dot-decimal--- notation, this is the recommended way to create an IP address.--- Additionally, it is used for the 'Show' and 'Read' instances--- of 'IPv4' to help keep things readable in GHCi.------ >>> let addr = ipv4 192 168 1 1--- >>> addr--- ipv4 192 168 1 1--- >>> getIPv4 addr--- 3232235777----ipv4 :: Word8 -> Word8 -> Word8 -> Word8 -> IPv4-ipv4 = fromOctets---- | An alias for the 'ipv4' smart constructor.-fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> IPv4-fromOctets a b c d = fromOctets'- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)---- | An uncurried variant of 'fromOctets'.-fromTupleOctets :: (Word8,Word8,Word8,Word8) -> IPv4-fromTupleOctets (a,b,c,d) = fromOctets a b c d---- | Convert an 'IPv4' address into a quadruple of octets. The first--- element in the quadruple is the most significant octet. The last--- element is the least significant octet.-toOctets :: IPv4 -> (Word8,Word8,Word8,Word8)-toOctets (IPv4 w) =- ( fromIntegral (shiftR w 24)- , fromIntegral (shiftR w 16)- , fromIntegral (shiftR w 8)- , fromIntegral w- )---- | The IP address representing any host.------ >>> any--- ipv4 0 0 0 0-any :: IPv4-any = IPv4 0---- | The local loopback IP address.------ >>> loopback--- ipv4 127 0 0 1-loopback :: IPv4-loopback = fromOctets 127 0 0 1---- | A useful and common alias for 'loopback'.------ >>> localhost--- ipv4 127 0 0 1-localhost :: IPv4-localhost = loopback---- | The broadcast IP address.------ >>> broadcast--- ipv4 255 255 255 255-broadcast :: IPv4-broadcast = fromOctets 255 255 255 255---- | Checks to see if the 'IPv4' address belongs to a private--- network. The three private networks that are checked are--- @10.0.0.0/8@, @172.16.0.0/12@, and @192.168.0.0/16@.-private :: IPv4 -> Bool-private (IPv4 w) =- mask8 .&. w == p24- || mask12 .&. w == p20- || mask16 .&. w == p16---- | Checks to see if the 'IPv4' address belongs to a reserved--- network. This includes the three private networks that 'private'--- checks along with several other ranges that are not used--- on the public Internet.-reserved :: IPv4 -> Bool-reserved =- let a = getIPv4 $ fromOctets' 0 0 0 0- b = getIPv4 $ fromOctets' 100 64 0 0- c = getIPv4 $ fromOctets' 127 0 0 0- d = getIPv4 $ fromOctets' 169 254 0 0- e = getIPv4 $ fromOctets' 192 0 0 0- f = getIPv4 $ fromOctets' 192 0 2 0- g = getIPv4 $ fromOctets' 192 88 99 0- h = getIPv4 $ fromOctets' 198 18 0 0- i = getIPv4 $ fromOctets' 198 51 100 0- j = getIPv4 $ fromOctets' 203 0 113 0- k = getIPv4 $ fromOctets' 224 0 0 0- l = getIPv4 $ fromOctets' 240 0 0 0- m = getIPv4 $ fromOctets' 255 255 255 255- in \(IPv4 w) -> mask8 .&. w == p24- || mask12 .&. w == p20- || mask16 .&. w == p16- || mask8 .&. w == a- || mask10 .&. w == b- || mask8 .&. w == c- || mask16 .&. w == d- || mask24 .&. w == e- || mask24 .&. w == f- || mask24 .&. w == g- || mask15 .&. w == h- || mask24 .&. w == i- || mask24 .&. w == j- || mask4 .&. w == k- || mask4 .&. w == l- || mask32 .&. w == m--mask8,mask4,mask12,mask16,mask10,mask24,mask32,mask15 :: Word32-mask4 = 0xF0000000-mask8 = 0xFF000000-mask10 = 0xFFC00000-mask12 = 0xFFF00000-mask15 = 0xFFFE0000-mask16 = 0xFFFF0000-mask24 = 0xFFFFFF00-mask32 = 0xFFFFFFFF---- | Checks to see if the 'IPv4' address is publicly routable.------ prop> public x == not (reserved x)-public :: IPv4 -> Bool-public = not . reserved---- | Encode an 'IPv4' address to 'Text' using dot-decimal notation:------ >>> T.putStrLn (encode (ipv4 192 168 2 47))--- 192.168.2.47-encode :: IPv4 -> Text-encode = toDotDecimalText---- | Decode an 'IPv4' address.------ >>> decode "192.168.2.47"--- Just (ipv4 192 168 2 47)------ >>> decode "10.100.256.256"--- Nothing-decode :: Text -> Maybe IPv4-decode = decodeIPv4TextMaybe---- | Encode an 'IPv4' address to a text 'TBuilder.Builder'.------ >>> builder (ipv4 192 168 2 47)--- "192.168.2.47"-builder :: IPv4 -> TBuilder.Builder-builder = toDotDecimalBuilder---- | Parse an 'IPv4' address using a 'TextRead.Reader'.------ >>> reader "192.168.2.47"--- Right (ipv4 192 168 2 47,"")------ >>> reader "192.168.2.470"--- Left "All octets in an IPv4 address must be between 0 and 255"-reader :: TextRead.Reader IPv4-reader = decodeIPv4TextReader---- | Parse an 'IPv4' address using a 'AT.Parser'.------ >>> AT.parseOnly parser "192.168.2.47"--- Right (ipv4 192 168 2 47)------ >>> AT.parseOnly parser "192.168.2.470"--- Left "Failed reading: All octets in an IPv4 address must be between 0 and 255"-parser :: AT.Parser IPv4-parser = dotDecimalParser---- | Encode an 'IPv4' address to a UTF-8 encoded 'ByteString'.------ >>> encodeUtf8 (ipv4 192 168 2 47)--- "192.168.2.47"-encodeUtf8 :: IPv4 -> ByteString-encodeUtf8 = toBSPreAllocated--toBSPreAllocated :: IPv4 -> ByteString-toBSPreAllocated (IPv4 !w) = I.unsafeCreateUptoN 15 (\ptr1 ->- do len1 <- writeWord ptr1 w1- let ptr2 = ptr1 `plusPtr` len1- poke ptr2 dot- len2 <- writeWord (ptr2 `plusPtr` 1) w2- let ptr3 = ptr2 `plusPtr` len2 `plusPtr` 1- poke ptr3 dot- len3 <- writeWord (ptr3 `plusPtr` 1) w3- let ptr4 = ptr3 `plusPtr` len3 `plusPtr` 1- poke ptr4 dot- len4 <- writeWord (ptr4 `plusPtr` 1) w4- return (3 + len1 + len2 + len3 + len4))- where w1 = fromIntegral $ shiftR w 24- w2 = fromIntegral $ shiftR w 16- w3 = fromIntegral $ shiftR w 8- w4 = fromIntegral w- dot = 46 :: Word8- writeWord :: Ptr Word8 -> Word8 -> IO Int- writeWord !ptr !word- | word >= 100 = do- let int = fromIntegral word- indx = int + int + int- get3 = fromIntegral . ByteString.unsafeIndex threeDigits- poke ptr (get3 indx)- poke (ptr `plusPtr` 1) (get3 (indx + 1))- poke (ptr `plusPtr` 2) (get3 (indx + 2))- return 3- | word >= 10 = do- let int = fromIntegral word- indx = int + int- get2 = fromIntegral . ByteString.unsafeIndex twoDigits- poke ptr (get2 indx)- poke (ptr `plusPtr` 1) (get2 (indx + 1))- return 2- | otherwise = do- poke ptr (word + 48)- return 1---- | Decode a UTF8-encoded 'ByteString' into an 'IPv4'.------ >>> decodeUtf8 "192.168.2.47"--- Just (ipv4 192 168 2 47)-decodeUtf8 :: ByteString -> Maybe IPv4-decodeUtf8 = decode <=< rightToMaybe . decodeUtf8'--- This (decodeUtf8) should be rewritten to not go through text--- as an intermediary.---- | Encode an 'IPv4' as a 'Builder.Builder'-builderUtf8 :: IPv4 -> Builder.Builder-builderUtf8 = Builder.byteString . encodeUtf8---- | Parse an 'IPv4' using a 'AB.Parser'.------ >>> AB.parseOnly parserUtf8 "192.168.2.47"--- Right (ipv4 192 168 2 47)------ >>> AB.parseOnly parserUtf8 "192.168.2.470"--- Left "Failed reading: All octets in an ipv4 address must be between 0 and 255"-parserUtf8 :: AB.Parser IPv4-parserUtf8 = fromOctets'- <$> (AB.decimal >>= limitSize)- <* AB.char '.'- <*> (AB.decimal >>= limitSize)- <* AB.char '.'- <*> (AB.decimal >>= limitSize)- <* AB.char '.'- <*> (AB.decimal >>= limitSize)- where- limitSize i =- if i > 255- then fail "All octets in an ipv4 address must be between 0 and 255"- 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- that can only use 'String' to deal with textual data (such as- @pandoc@, @hxr@, or @network@).---}---- | Encode an 'IPv4' as a 'String'.-encodeString :: IPv4 -> String-encodeString = Text.unpack . encode---- | Decode an 'IPv4' from a 'String'.-decodeString :: String -> Maybe IPv4-decodeString = decode . Text.pack----- | A 32-bit Internet Protocol version 4 address. To use this with the--- @network@ library, it is necessary to use @Network.Socket.htonl@ to--- 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,Storable)--instance NFData IPv4--instance Show IPv4 where- showsPrec p addr = showParen (p > 10)- $ showString "ipv4 "- . showsPrec 11 a- . showChar ' '- . showsPrec 11 b- . showChar ' '- . showsPrec 11 c- . showChar ' '- . showsPrec 11 d- where- (a,b,c,d) = toOctets addr--instance Read IPv4 where- readPrec = parens $ prec 10 $ do- Ident "ipv4" <- lexP- a <- step readPrec- b <- step readPrec- c <- step readPrec- d <- step readPrec- return (fromOctets a b c d)---- | Print an 'IPv4' using the textual encoding.-print :: IPv4 -> IO ()-print = TIO.putStrLn . encode--newtype instance UVector.MVector s IPv4 = MV_IPv4 (PVector.MVector s IPv4)-newtype instance UVector.Vector IPv4 = V_IPv4 (PVector.Vector IPv4)--instance UVector.Unbox IPv4--instance MGVector.MVector UVector.MVector IPv4 where- {-# INLINE basicLength #-}- {-# INLINE basicUnsafeSlice #-}- {-# INLINE basicOverlaps #-}- {-# INLINE basicUnsafeNew #-}- {-# INLINE basicInitialize #-}- {-# INLINE basicUnsafeReplicate #-}- {-# INLINE basicUnsafeRead #-}- {-# INLINE basicUnsafeWrite #-}- {-# INLINE basicClear #-}- {-# INLINE basicSet #-}- {-# INLINE basicUnsafeCopy #-}- {-# INLINE basicUnsafeGrow #-}- basicLength (MV_IPv4 v) = MGVector.basicLength v- basicUnsafeSlice i n (MV_IPv4 v) = MV_IPv4 $ MGVector.basicUnsafeSlice i n v- basicOverlaps (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicOverlaps v1 v2- basicUnsafeNew n = MV_IPv4 `liftM` MGVector.basicUnsafeNew n- basicInitialize (MV_IPv4 v) = MGVector.basicInitialize v- basicUnsafeReplicate n x = MV_IPv4 `liftM` MGVector.basicUnsafeReplicate n x- basicUnsafeRead (MV_IPv4 v) i = MGVector.basicUnsafeRead v i- basicUnsafeWrite (MV_IPv4 v) i x = MGVector.basicUnsafeWrite v i x- basicClear (MV_IPv4 v) = MGVector.basicClear v- basicSet (MV_IPv4 v) x = MGVector.basicSet v x- basicUnsafeCopy (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicUnsafeCopy v1 v2- basicUnsafeMove (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicUnsafeMove v1 v2- basicUnsafeGrow (MV_IPv4 v) n = MV_IPv4 `liftM` MGVector.basicUnsafeGrow v n--instance GVector.Vector UVector.Vector IPv4 where- {-# INLINE basicUnsafeFreeze #-}- {-# INLINE basicUnsafeThaw #-}- {-# INLINE basicLength #-}- {-# INLINE basicUnsafeSlice #-}- {-# INLINE basicUnsafeIndexM #-}- {-# INLINE elemseq #-}- basicUnsafeFreeze (MV_IPv4 v) = V_IPv4 `liftM` GVector.basicUnsafeFreeze v- basicUnsafeThaw (V_IPv4 v) = MV_IPv4 `liftM` GVector.basicUnsafeThaw v- basicLength (V_IPv4 v) = GVector.basicLength v- basicUnsafeSlice i n (V_IPv4 v) = V_IPv4 $ GVector.basicUnsafeSlice i n v- basicUnsafeIndexM (V_IPv4 v) i = GVector.basicUnsafeIndexM v i- basicUnsafeCopy (MV_IPv4 mv) (V_IPv4 v) = GVector.basicUnsafeCopy mv v- elemseq _ = seq--instance ToJSON IPv4 where- toJSON = Aeson.String . encode--instance FromJSON IPv4 where- parseJSON = Aeson.withText "IPv4" aesonParser--#if MIN_VERSION_aeson(1,0,0)-instance ToJSONKey IPv4 where- toJSONKey = ToJSONKeyText- encode- (\addr -> Aeson.unsafeToEncoding $ Builder.char7 '"' <> builderUtf8 addr <> Builder.char7 '"')--instance FromJSONKey IPv4 where- fromJSONKey = FromJSONKeyTextParser aesonParser-#endif--aesonParser :: Text -> Aeson.Parser IPv4-aesonParser t = case decode t of- 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---------------------------------------decodeIPv4TextMaybe :: Text -> Maybe IPv4-decodeIPv4TextMaybe t = case decodeIPv4TextReader t of- Left _ -> Nothing- Right (w,t') -> if Text.null t'- then Just w- else Nothing--decodeIPv4TextReader :: TextRead.Reader IPv4-decodeIPv4TextReader t1' = do- (a,t2) <- TextRead.decimal t1'- t2' <- stripDecimal t2- (b,t3) <- TextRead.decimal t2'- t3' <- stripDecimal t3- (c,t4) <- TextRead.decimal t3'- t4' <- stripDecimal t4- (d,t5) <- TextRead.decimal t4'- if a > 255 || b > 255 || c > 255 || d > 255- then Left ipOctetSizeErrorMsg- else Right (fromOctets' a b c d,t5)--stripDecimal :: Text -> Either String Text-stripDecimal t = case Text.uncons t of- Nothing -> Left "expected a dot but input ended instead"- Just (c,tnext) -> if c == '.'- then Right tnext- else Left "expected a dot but found a different character"---- | This is sort of a misnomer. It takes Word to make--- dotDecimalParser perform better. This is mostly--- for internal use. The arguments must all fit--- in a Word8.-fromOctets' :: Word -> Word -> Word -> Word -> IPv4-fromOctets' a b c d = IPv4 $ fromIntegral- ( shiftL a 24- .|. shiftL b 16- .|. shiftL c 8- .|. d- )--p24 :: Word32-p24 = getIPv4 (fromOctets' 10 0 0 0)--p20 :: Word32-p20 = getIPv4 (fromOctets' 172 16 0 0)--p16 :: Word32-p16 = getIPv4 (fromOctets' 192 168 0 0)---- | This does not do an endOfInput check because it is--- reused in the range parser implementation.-dotDecimalParser :: AT.Parser IPv4-dotDecimalParser = fromOctets'- <$> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- where- limitSize i =- if i > 255- then fail ipOctetSizeErrorMsg- else return i--ipOctetSizeErrorMsg :: String-ipOctetSizeErrorMsg = "All octets in an IPv4 address must be between 0 and 255"--toDotDecimalText :: IPv4 -> Text-toDotDecimalText = toTextPreAllocated--toDotDecimalBuilder :: IPv4 -> TBuilder.Builder-toDotDecimalBuilder = TBuilder.fromText . toTextPreAllocated---- | I think that this function can be improved. Right now, it--- always allocates enough space for a fifteen-character text--- rendering of an IP address. I think that it should be possible--- to do more of the math upfront and allocate less space.-toTextPreAllocated :: IPv4 -> Text-toTextPreAllocated (IPv4 w) =- let w1 = 255 .&. unsafeShiftR (fromIntegral w) 24- w2 = 255 .&. unsafeShiftR (fromIntegral w) 16- w3 = 255 .&. unsafeShiftR (fromIntegral w) 8- w4 = 255 .&. fromIntegral w- in toTextPreallocatedPartTwo w1 w2 w3 w4--toTextPreallocatedPartTwo :: Word -> Word -> Word -> Word -> Text-toTextPreallocatedPartTwo !w1 !w2 !w3 !w4 =-#ifdef ghcjs_HOST_OS- let dotStr = "."- in Text.pack $ concat- [ show w1- , "."- , show w2- , "."- , show w3- , "."- , show w4- ]-#else- let dot = 46- (arr,len) = runST $ do- marr <- TArray.new 15- i1 <- putAndCount 0 w1 marr- let n1 = i1- n1' = i1 + 1- TArray.unsafeWrite marr n1 dot- i2 <- putAndCount n1' w2 marr- let n2 = i2 + n1'- n2' = n2 + 1- TArray.unsafeWrite marr n2 dot- i3 <- putAndCount n2' w3 marr- let n3 = i3 + n2'- n3' = n3 + 1- TArray.unsafeWrite marr n3 dot- i4 <- putAndCount n3' w4 marr- theArr <- TArray.unsafeFreeze marr- return (theArr,i4 + n3')- in Text arr 0 len-#endif--twoDigits :: ByteString-twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99-{-# NOINLINE twoDigits #-}--threeDigits :: ByteString-threeDigits = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 999-{-# NOINLINE threeDigits #-}--i2w :: Integral a => a -> Word16-i2w v = zero + fromIntegral v--zero :: Word16-zero = 48--putAndCount :: Int -> Word -> TArray.MArray s -> ST s Int-putAndCount pos w marr- | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1- | w < 100 = write2 pos w >> return 2- | otherwise = write3 pos w >> return 3- where- write2 off i0 = do- let i = fromIntegral i0; j = i + i- TArray.unsafeWrite marr off $ get2 j- TArray.unsafeWrite marr (off + 1) $ get2 (j + 1)- write3 off i0 = do- let i = fromIntegral i0; j = i + i + i- TArray.unsafeWrite marr off $ get3 j- TArray.unsafeWrite marr (off + 1) $ get3 (j + 1)- TArray.unsafeWrite marr (off + 2) $ get3 (j + 2)- get2 = fromIntegral . ByteString.unsafeIndex twoDigits- get3 = fromIntegral . ByteString.unsafeIndex threeDigits--rightToMaybe :: Either a b -> Maybe b-rightToMaybe = either (const Nothing) Just--{- $interoperability--The @<http://hackage.haskell.org/package/network network>@ 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@.---}---- $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)---- | The inclusive upper bound of an 'IPv4Range'.------ >>> T.putStrLn $ encode $ upperInclusive $ IPv4Range (ipv4 10 10 1 160) 25--- 10.10.1.255-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---- | A stream-polymorphic generator over an 'IPv4Range'.--- For more information, see <http://www.haskellforall.com/2014/11/how-to-build-library-agnostic-streaming.html How to build library-agnostic streaming sources>.-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'---- | Encode an 'IPv4Range' as 'Text'.------ >>> encodeRange (IPv4Range (ipv4 172 16 0 0) 12)--- "172.16.0.0/12"-encodeRange :: IPv4Range -> Text-encodeRange = rangeToDotDecimalText---- | Decode an 'IPv4Range' from 'Text'.------ >>> decodeRange "172.16.0.0/12"--- Just (IPv4Range {ipv4RangeBase = ipv4 172 16 0 0, ipv4RangeLength = 12})--- >>> decodeRange "192.168.25.254/16"--- Just (IPv4Range {ipv4RangeBase = ipv4 192 168 0 0, ipv4RangeLength = 16})-decodeRange :: Text -> Maybe IPv4Range-decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)---- | Encode an 'IPv4Range' to a 'TBuilder.Builder'.------ >>> builderRange (IPv4Range (ipv4 172 16 0 0) 12)--- "172.16.0.0/12"-builderRange :: IPv4Range -> TBuilder.Builder-builderRange = rangeToDotDecimalBuilder---- | Parse an 'IPv4Range' using a 'AT.Parser'.------ >>> AT.parseOnly parserRange "192.168.25.254/16"--- Right (IPv4Range {ipv4RangeBase = ipv4 192 168 0 0, ipv4RangeLength = 16})-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---- | Print an 'IPv4Range'. Helper function that--- 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 NFData IPv4Range-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-+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++{- | This module provides the IPv4 data type and functions for working+ with it.+-}+module Net.IPv4+ ( -- * Conversion Functions+ ipv4+ , fromOctets+ , fromTupleOctets+ , toOctets++ -- * Special IP Addresses+ , any+ , loopback+ , localhost+ , broadcast++ -- * Range Predicates+ , private+ , reserved+ , public++ -- * Textual Conversion++ -- ** Text+ , encode+ , decode+ , builder+ , reader+ , parser+ , decodeShort+ , encodeShort++ -- ** UTF-8 ByteString+ , encodeUtf8+ , decodeUtf8+ , builderUtf8+ , parserUtf8++ -- ** UTF-8 Bytes+ , decodeUtf8Bytes+ , parserUtf8Bytes+ , byteArrayBuilderUtf8+ , boundedBuilderUtf8++ -- ** Non-textual Bytes+ , boundedBuilderOctetsBE+ , boundedBuilderOctetsLE++ -- ** String+ -- $string+ , encodeString+ , decodeString++ -- ** Printing+ , print++ -- * IPv4 Ranges++ -- ** Range functions+ , range+ , fromBounds+ , normalize+ , contains+ , isSubsetOf+ , member+ , lowerInclusive+ , upperInclusive++ -- ** Conversion to IPv4+ , toList+ , toGenerator++ -- ** Private Ranges+ , private24+ , private20+ , private16++ -- ** Textual Conversion++ -- *** Text+ , encodeRange+ , decodeRange+ , builderRange+ , parserRange+ , printRange++ -- ** UTF-8 Bytes+ , parserRangeUtf8Bytes+ , parserRangeUtf8BytesLenient++ -- * Types+ , IPv4 (..)+ , IPv4#+ , IPv4Range (..)++ -- * Unboxing++ -- | These functions are useful for micro-optimizing+ -- when GHC does a poor job with worker-wrapper.+ , box+ , unbox+ , parserUtf8Bytes#++ -- * Interoperability+ -- $interoperability+ ) where++import Control.DeepSeq (NFData)+import Control.Monad+import Control.Monad.ST (ST, runST)+import Data.Aeson (FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..))+import Data.Bits (Bits (..))+import Data.ByteString (ByteString)+import Data.Coerce (coerce)+import Data.Data (Data)+import Data.Hashable+import Data.Ix (Ix)+import Data.Primitive.Types (Prim)+import Data.Text (Text)+import Data.Text.Builder.Common.Compat (Codepoint)+import Data.Text.Encoding (decodeUtf8')+import Data.Text.Internal (Text (..))+import Data.Text.Short (ShortText)+import Data.Vector.Generic.Mutable (MVector (..))+import Data.Word+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (Storable, poke)+import GHC.Exts (Word#)+import GHC.Generics (Generic)+import Text.ParserCombinators.ReadPrec (prec, step)+import Text.Printf (printf)+import Text.Read (Lexeme (Ident), Read (..), lexP, parens)+import Prelude hiding (any, print)++import qualified Arithmetic.Nat as Nat+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.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Internal as I+import qualified Data.ByteString.Short.Internal as BSS+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Builder as UB+import qualified Data.Bytes.Builder.Bounded as BB+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Char as Char+import qualified Data.Primitive as PM+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.Text.Short as TS+import qualified Data.Text.Short.Unsafe as TS+import qualified Data.Vector.Generic as GVector+import qualified Data.Vector.Generic.Mutable as MGVector+import qualified Data.Vector.Primitive as PVector+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Unboxed.Mutable as MUVector+import qualified GHC.Word.Compat as Compat++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as AesonKey+#endif++{- $setup++These are here to get doctest's property checking to work++>>> :set -XOverloadedStrings+>>> import Test.QuickCheck (Arbitrary(..))+>>> import Net.IPv4 (getIPv4)+>>> import qualified Prelude as P+>>> import qualified Data.Text.IO as T+>>> import qualified Data.Bytes.Text.Ascii as Ascii+>>> import qualified Data.Attoparsec.Text as AT+>>> import qualified Data.ByteString.Builder as Builder+>>> import qualified Data.Bytes.Builder as UB+>>> import qualified Data.Attoparsec.ByteString.Char8 as AB+>>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }+>>> instance Arbitrary IPv4.IPv4Range where { arbitrary = IPv4.IPv4Range <$> arbitrary <*> arbitrary }+>>> import qualified Data.Bytes.Chunks as Chunks+-}++{- | Create an 'IPv4' address from four octets. The first argument+ is the most significant octet. The last argument is the least+ significant. Since IP addresses are commonly written using dot-decimal+ notation, this is the recommended way to create an IP address.+ Additionally, it is used for the 'Show' and 'Read' instances+ of 'IPv4' to help keep things readable in GHCi.++ >>> let addr = IPv4.ipv4 192 168 1 1+ >>> addr+ ipv4 192 168 1 1+ >>> getIPv4 addr+ 3232235777+-}+ipv4 :: Word8 -> Word8 -> Word8 -> Word8 -> IPv4+ipv4 = fromOctets++-- | An alias for the 'ipv4' smart constructor.+fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> IPv4+fromOctets a b c d =+ fromOctets'+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)++-- | An uncurried variant of 'fromOctets'.+fromTupleOctets :: (Word8, Word8, Word8, Word8) -> IPv4+fromTupleOctets (a, b, c, d) = fromOctets a b c d++{- | Convert an 'IPv4' address into a quadruple of octets. The first+ element in the quadruple is the most significant octet. The last+ element is the least significant octet.+-}+toOctets :: IPv4 -> (Word8, Word8, Word8, Word8)+toOctets (IPv4 w) =+ ( fromIntegral (shiftR w 24)+ , fromIntegral (shiftR w 16)+ , fromIntegral (shiftR w 8)+ , fromIntegral w+ )++{- | The IP address representing any host.++ >>> IPv4.any+ ipv4 0 0 0 0+-}+any :: IPv4+any = IPv4 0++{- | The local loopback IP address.++ >>> IPv4.loopback+ ipv4 127 0 0 1+-}+loopback :: IPv4+loopback = fromOctets 127 0 0 1++{- | A useful and common alias for 'loopback'.++ >>> IPv4.localhost+ ipv4 127 0 0 1+-}+localhost :: IPv4+localhost = loopback++{- | The broadcast IP address.++ >>> IPv4.broadcast+ ipv4 255 255 255 255+-}+broadcast :: IPv4+broadcast = fromOctets 255 255 255 255++{- | Checks to see if the 'IPv4' address belongs to a private+network. The three private networks that are checked are+@10.0.0.0/8@, @172.16.0.0/12@, and @192.168.0.0/16@.+-}+private :: IPv4 -> Bool+private (IPv4 w) =+ mask8 .&. w == p24+ || mask12 .&. w == p20+ || mask16 .&. w == p16++----------------------------------------+-- Note [The implementation of reserved]+----------------------------------------+-- The @reserved@ function has been optimized to perform well in the+-- microbenchmark @CIDR Inclusion/reserved@. We perform an inital case+-- on the upper three bits (8 possible values), which GHC will compile+-- to a jump table. This helps because the reserved ranges of IPv4+-- addresses are somewhat clustered. Notice that everything in+-- 32.0.0.0/3, 64.0.0.0/3, and 128.0.0.0/3 is publicly routable, and+-- everything in 224.0.0.0/3 is reserved. This means that for exactly+-- half of the IPv4 addresses that exist, this single jump is sufficient+-- for determining whether or not they are reserved. For the others,+-- there is a little more work to do, particularly in the 192.0.0.0/3+-- range. On the laptop that ran the microbenchmark, this function+-- decided the reservedness of 100 random IPv4 addresses in 200ns.++{- | Checks to see if the 'IPv4' address belongs to a reserved+network. This includes the three private networks that 'private'+checks along with several other ranges that are not used+on the public Internet. The implementation of this function+is optimized.+-}+reserved :: IPv4 -> Bool+reserved !(IPv4 w) = case unsafeShiftR w 29 of+ 0 ->+ let a = getIPv4 $ fromOctets' 0 0 0 0+ y = getIPv4 $ fromOctets' 10 0 0 0+ in mask8 .&. w == a+ || mask8 .&. w == y+ 1 -> False+ 2 -> False+ 3 ->+ let b = getIPv4 $ fromOctets' 100 64 0 0+ c = getIPv4 $ fromOctets' 127 0 0 0+ in mask8 .&. w == c+ || mask10 .&. w == b+ 4 -> False+ 5 ->+ let d = getIPv4 $ fromOctets' 169 254 0 0+ x = getIPv4 $ fromOctets' 172 16 0 0+ in mask12 .&. w == x+ || mask16 .&. w == d+ 6 ->+ let e = getIPv4 $ fromOctets' 192 0 0 0+ f = getIPv4 $ fromOctets' 192 0 2 0+ g = getIPv4 $ fromOctets' 192 88 99 0+ h = getIPv4 $ fromOctets' 198 18 0 0+ i = getIPv4 $ fromOctets' 198 51 100 0+ j = getIPv4 $ fromOctets' 203 0 113 0+ z = getIPv4 $ fromOctets' 192 168 0 0+ in mask15 .&. w == h+ || mask16 .&. w == z+ || mask24 .&. w == e+ || mask24 .&. w == f+ || mask24 .&. w == g+ || mask24 .&. w == i+ || mask24 .&. w == j+ _ -> True++mask8, mask12, mask16, mask10, mask24, mask15 :: Word32+mask8 = 0xFF000000+mask10 = 0xFFC00000+mask12 = 0xFFF00000+mask15 = 0xFFFE0000+mask16 = 0xFFFF0000+mask24 = 0xFFFFFF00++{- | Checks to see if the 'IPv4' address is publicly routable.++prop> IPv4.public x == not (IPv4.reserved x)+-}+public :: IPv4 -> Bool+public = not . reserved++{- | Encode an 'IPv4' address to 'Text' using dot-decimal notation:++ >>> T.putStrLn (IPv4.encode (IPv4.ipv4 192 168 2 47))+ 192.168.2.47+-}+encode :: IPv4 -> Text+encode = toDotDecimalText++{- | Decode an 'IPv4' address.++ >>> IPv4.decode "192.168.2.47"+ Just (ipv4 192 168 2 47)++ >>> IPv4.decode "10.100.256.256"+ Nothing+-}+decode :: Text -> Maybe IPv4+decode = decodeIPv4TextMaybe++{- | Encode an 'IPv4' address to a text 'TBuilder.Builder'.++ >>> IPv4.builder (IPv4.ipv4 192 168 2 47)+ "192.168.2.47"+-}+builder :: IPv4 -> TBuilder.Builder+builder = toDotDecimalBuilder++{- | Parse an 'IPv4' address using a 'TextRead.Reader'.++ >>> IPv4.reader "192.168.2.47"+ Right (ipv4 192 168 2 47,"")++ >>> IPv4.reader "192.168.2.470"+ Left "All octets in an IPv4 address must be between 0 and 255"+-}+reader :: TextRead.Reader IPv4+reader = decodeIPv4TextReader++{- | Parse an 'IPv4' address using a 'AT.Parser'.++ >>> AT.parseOnly IPv4.parser "192.168.2.47"+ Right (ipv4 192 168 2 47)++ >>> AT.parseOnly IPv4.parser "192.168.2.470"+ Left "Failed reading: All octets in an IPv4 address must be between 0 and 255"+-}+parser :: AT.Parser IPv4+parser = dotDecimalParser++{- | Encode an 'IPv4' address to a UTF-8 encoded 'ByteString'.++ >>> IPv4.encodeUtf8 (IPv4.ipv4 192 168 2 47)+ "192.168.2.47"+-}+encodeUtf8 :: IPv4 -> ByteString+encodeUtf8 = toBSPreAllocated++toBSPreAllocated :: IPv4 -> ByteString+toBSPreAllocated (IPv4 !w) =+ I.unsafeCreateUptoN+ 15+ ( \ptr1 ->+ do+ len1 <- writeWord ptr1 w1+ let ptr2 = ptr1 `plusPtr` len1+ poke ptr2 dot+ len2 <- writeWord (ptr2 `plusPtr` 1) w2+ let ptr3 = ptr2 `plusPtr` len2 `plusPtr` 1+ poke ptr3 dot+ len3 <- writeWord (ptr3 `plusPtr` 1) w3+ let ptr4 = ptr3 `plusPtr` len3 `plusPtr` 1+ poke ptr4 dot+ len4 <- writeWord (ptr4 `plusPtr` 1) w4+ return (3 + len1 + len2 + len3 + len4)+ )+ where+ w1 = fromIntegral $ shiftR w 24+ w2 = fromIntegral $ shiftR w 16+ w3 = fromIntegral $ shiftR w 8+ w4 = fromIntegral w+ dot = 46 :: Word8+ writeWord :: Ptr Word8 -> Word8 -> IO Int+ writeWord !ptr !word+ | word >= 100 = do+ let int = fromIntegral word+ indx = int + int + int+ get3 = fromIntegral . ByteString.unsafeIndex threeDigits+ poke ptr (get3 indx)+ poke (ptr `plusPtr` 1) (get3 (indx + 1))+ poke (ptr `plusPtr` 2) (get3 (indx + 2))+ return 3+ | word >= 10 = do+ let int = fromIntegral word+ indx = int + int+ get2 = fromIntegral . ByteString.unsafeIndex twoDigits+ poke ptr (get2 indx)+ poke (ptr `plusPtr` 1) (get2 (indx + 1))+ return 2+ | otherwise = do+ poke ptr (word + 48)+ return 1++{- | Decode a UTF8-encoded 'ByteString' into an 'IPv4'.++ >>> IPv4.decodeUtf8 "192.168.2.47"+ Just (ipv4 192 168 2 47)++ Currently not terribly efficient since the implementation+ re-encodes the argument as UTF-16 text before decoding that+ IPv4 address from that. PRs to fix this are welcome.+-}+decodeUtf8 :: ByteString -> Maybe IPv4+decodeUtf8 = decode <=< rightToMaybe . decodeUtf8'++-- This (decodeUtf8) should be rewritten to not go through text+-- as an intermediary.++{- | Decode 'ShortText' as an 'IPv4' address.++ >>> IPv4.decodeShort "192.168.3.48"+ Just (ipv4 192 168 3 48)+-}+decodeShort :: ShortText -> Maybe IPv4+decodeShort t = decodeUtf8Bytes (Bytes.fromByteArray b)+ where+ b = shortByteStringToByteArray (TS.toShortByteString t)++{- | Encode an 'IPv4' address as 'ShortText'.++ >>> IPv4.encodeShort (IPv4.ipv4 192 168 5 99)+ "192.168.5.99"+-}+encodeShort :: IPv4 -> ShortText+encodeShort !w =+ id $+ TS.fromShortByteStringUnsafe $+ byteArrayToShortByteString $+ BB.run Nat.constant $+ boundedBuilderUtf8 $+ w++shortByteStringToByteArray :: BSS.ShortByteString -> PM.ByteArray+shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x++byteArrayToShortByteString :: PM.ByteArray -> BSS.ShortByteString+byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x++{- | Decode UTF-8-encoded 'Bytes' into an 'IPv4' address.++ >>> IPv4.decodeUtf8Bytes (Ascii.fromString "127.0.0.1")+ Just (ipv4 127 0 0 1)+-}+decodeUtf8Bytes :: Bytes.Bytes -> Maybe IPv4+decodeUtf8Bytes !b = case Parser.parseBytes (parserUtf8Bytes ()) b of+ Parser.Success (Parser.Slice _ len addr) -> case len of+ 0 -> Just addr+ _ -> Nothing+ Parser.Failure _ -> Nothing++{- | Parse UTF-8-encoded 'Bytes' as an 'IPv4' address.++ >>> Parser.parseBytes (IPv4.parserUtf8Bytes ()) (Ascii.fromString "10.0.1.254")+ Success (Slice {offset = 10, length = 0, value = ipv4 10 0 1 254})+-}+parserUtf8Bytes :: e -> Parser.Parser e s IPv4+{-# INLINE parserUtf8Bytes #-}+parserUtf8Bytes e = coerce (Parser.boxWord32 (parserUtf8Bytes# e))++-- | Variant of 'parserUtf8Bytes' with unboxed result type.+parserUtf8Bytes# :: e -> Parser.Parser e s IPv4#+{-# NOINLINE parserUtf8Bytes# #-}+parserUtf8Bytes# e = Parser.unboxWord32 $ do+ !a <- Latin.decWord8 e+ Latin.char e '.'+ !b <- Latin.decWord8 e+ Latin.char e '.'+ !c <- Latin.decWord8 e+ Latin.char e '.'+ !d <- Latin.decWord8 e+ pure (getIPv4 (fromOctets a b c d))++{- | Parse UTF-8-encoded 'Bytes' into an 'IPv4Range'.+This requires the mask to be present.++>>> maybe (putStrLn "nope") IPv4.printRange $ Parser.parseBytesMaybe (IPv4.parserRangeUtf8Bytes ()) (Ascii.fromString "192.168.0.0/16")+192.168.0.0/16+>>> maybe (putStrLn "nope") IPv4.printRange $ Parser.parseBytesMaybe (IPv4.parserRangeUtf8Bytes ()) (Ascii.fromString "10.10.10.1")+nope++See 'parserRangeUtf8BytesLenient' for a variant that treats+a missing mask as a @/32@ mask.+-}+parserRangeUtf8Bytes :: e -> Parser.Parser e s IPv4Range+parserRangeUtf8Bytes e = do+ base <- parserUtf8Bytes e+ Latin.char e '/'+ theMask <- Latin.decWord8 e+ if theMask > 32+ then Parser.fail e+ else pure $! normalize (IPv4Range base theMask)++{- | Variant of 'parserRangeUtf8Bytes' that allows the mask+to be omitted. An omitted mask is treated as a @/32@ mask.++>>> maybe (putStrLn "nope") IPv4.printRange $ Parser.parseBytesMaybe (IPv4.parserRangeUtf8BytesLenient ()) (Ascii.fromString "192.168.0.0/16")+192.168.0.0/16+>>> maybe (putStrLn "nope") IPv4.printRange $ Parser.parseBytesMaybe (IPv4.parserRangeUtf8BytesLenient ()) (Ascii.fromString "10.10.10.1")+10.10.10.1/32+-}+parserRangeUtf8BytesLenient :: e -> Parser.Parser e s IPv4Range+parserRangeUtf8BytesLenient e = do+ base <- parserUtf8Bytes e+ Latin.trySatisfy (== '/') >>= \case+ True -> do+ theMask <- Latin.decWord8 e+ if theMask > 32+ then Parser.fail e+ else pure $! normalize (IPv4Range base theMask)+ False -> pure $! IPv4Range base 32++{- | Encode an 'IPv4' as a bytestring 'Builder.Builder'++>>> Builder.toLazyByteString (IPv4.builderUtf8 (IPv4.fromOctets 192 168 2 12))+"192.168.2.12"+-}+builderUtf8 :: IPv4 -> Builder.Builder+builderUtf8 = Builder.byteString . encodeUtf8++{- | Encode an 'IPv4' address as a unbounded byte array builder.++>>> Chunks.concat (UB.run 1 (IPv4.byteArrayBuilderUtf8 (IPv4.fromOctets 192 168 2 13)))+[0x31,0x39,0x32,0x2e,0x31,0x36,0x38,0x2e,0x32,0x2e,0x31,0x33]++Note that period is encoded by UTF-8 as @0x2e@.+-}+byteArrayBuilderUtf8 :: IPv4 -> UB.Builder+byteArrayBuilderUtf8 = UB.fromBounded Nat.constant . boundedBuilderUtf8++{- | Encode an 'IPv4' address as a bounded byte array builder.++>>> BB.run Nat.constant (IPv4.boundedBuilderUtf8 (IPv4.fromOctets 192 168 2 14))+[0x31, 0x39, 0x32, 0x2e, 0x31, 0x36, 0x38, 0x2e, 0x32, 0x2e, 0x31, 0x34]++Note that period is encoded by UTF-8 as @0x2e@.+-}+boundedBuilderUtf8 :: IPv4 -> BB.Builder 15+boundedBuilderUtf8 (IPv4 !w) =+ BB.word8Dec w1+ `BB.append` BB.ascii '.'+ `BB.append` BB.word8Dec w2+ `BB.append` BB.ascii '.'+ `BB.append` BB.word8Dec w3+ `BB.append` BB.ascii '.'+ `BB.append` BB.word8Dec w4+ where+ w1 = fromIntegral (shiftR w 24) :: Word8+ w2 = fromIntegral (shiftR w 16) :: Word8+ w3 = fromIntegral (shiftR w 8) :: Word8+ w4 = fromIntegral w :: Word8++{- | Encode 'IPv4' address to a sequence a 4 bytes with the first+byte representing corresponding to the most significant byte in+the address.++>>> BB.run Nat.constant (IPv4.boundedBuilderOctetsBE (IPv4.fromOctets 0xc0 0xa8 0x02 0x1f))+[0xc0, 0xa8, 0x02, 0x1f]+-}+boundedBuilderOctetsBE :: IPv4 -> BB.Builder 4+{-# INLINE boundedBuilderOctetsBE #-}+boundedBuilderOctetsBE (IPv4 !w) =+ BB.word8 w1+ `BB.append` BB.word8 w2+ `BB.append` BB.word8 w3+ `BB.append` BB.word8 w4+ where+ w1 = fromIntegral (shiftR w 24) :: Word8+ w2 = fromIntegral (shiftR w 16) :: Word8+ w3 = fromIntegral (shiftR w 8) :: Word8+ w4 = fromIntegral w :: Word8++{- | Encode 'IPv4' address to a sequence a 4 bytes with the first+byte representing corresponding to the least significant byte in+the address.++>>> BB.run Nat.constant (IPv4.boundedBuilderOctetsLE (IPv4.fromOctets 0xc0 0xa8 0x02 0x1f))+[0x1f, 0x02, 0xa8, 0xc0]+-}+boundedBuilderOctetsLE :: IPv4 -> BB.Builder 4+{-# INLINE boundedBuilderOctetsLE #-}+boundedBuilderOctetsLE (IPv4 !w) =+ BB.word8 w4+ `BB.append` BB.word8 w3+ `BB.append` BB.word8 w2+ `BB.append` BB.word8 w1+ where+ w1 = fromIntegral (shiftR w 24) :: Word8+ w2 = fromIntegral (shiftR w 16) :: Word8+ w3 = fromIntegral (shiftR w 8) :: Word8+ w4 = fromIntegral w :: Word8++{- | Parse an 'IPv4' using a 'AB.Parser'.++ >>> AB.parseOnly IPv4.parserUtf8 "192.168.2.47"+ Right (ipv4 192 168 2 47)++ >>> AB.parseOnly IPv4.parserUtf8 "192.168.2.470"+ Left "Failed reading: All octets in an ipv4 address must be between 0 and 255"+-}+parserUtf8 :: AB.Parser IPv4+parserUtf8 =+ fromOctets'+ <$> (AB.decimal >>= limitSize)+ <* AB.char '.'+ <*> (AB.decimal >>= limitSize)+ <* AB.char '.'+ <*> (AB.decimal >>= limitSize)+ <* AB.char '.'+ <*> (AB.decimal >>= limitSize)+ where+ limitSize i =+ if i > 255+ then fail "All octets in an ipv4 address must be between 0 and 255"+ 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+ that can only use 'String' to deal with textual data (such as+ @pandoc@, @hxr@, or @network@).+-}++-- | Encode an 'IPv4' as a 'String'.+encodeString :: IPv4 -> String+encodeString = Text.unpack . encode++-- | Decode an 'IPv4' from a 'String'.+decodeString :: String -> Maybe IPv4+decodeString = decode . Text.pack++{- | Unboxed variant of 'IPv4'. Before GHC 8.10, this is+implemented as a type synonym. Portable use of this type requires+treating it as though it were opaque. Use 'box' and 'unbox' to+convert between this and the lifted 'IPv4'.+-}+type IPv4# = Word#++-- | Convert an unboxed IPv4 address to a boxed one.+box :: IPv4# -> IPv4+{-# INLINE box #-}+box w = IPv4 (Compat.W32# w)++-- | Convert a boxed IPv4 address to an unboxed one.+unbox :: IPv4 -> IPv4#+{-# INLINE unbox #-}+unbox (IPv4 (Compat.W32# w)) = w++{- | A 32-bit Internet Protocol version 4 address. To use this with the+ @network@ library, it is necessary to use @Network.Socket.htonl@ to+ convert the underlying 'Word32' from host byte order to network byte+ order.+-}+newtype IPv4 = IPv4 {getIPv4 :: Word32}+ deriving (Bits.Bits, Bounded, Data, Enum, Eq, Bits.FiniteBits, Generic, Hashable, Ix, Ord, Prim, Storable)++instance NFData IPv4++instance Show IPv4 where+ showsPrec p addr =+ showParen (p > 10) $+ showString "ipv4 "+ . showsPrec 11 a+ . showChar ' '+ . showsPrec 11 b+ . showChar ' '+ . showsPrec 11 c+ . showChar ' '+ . showsPrec 11 d+ where+ (a, b, c, d) = toOctets addr++instance Read IPv4 where+ readPrec = parens $ prec 10 $ do+ Ident "ipv4" <- lexP+ a <- step readPrec+ b <- step readPrec+ c <- step readPrec+ d <- step readPrec+ return (fromOctets a b c d)++-- | Print an 'IPv4' using the textual encoding.+print :: IPv4 -> IO ()+print = TIO.putStrLn . encode++newtype instance UVector.MVector s IPv4 = MV_IPv4 (PVector.MVector s IPv4)+newtype instance UVector.Vector IPv4 = V_IPv4 (PVector.Vector IPv4)++instance UVector.Unbox IPv4++instance MGVector.MVector UVector.MVector IPv4 where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicInitialize #-}+ {-# INLINE basicUnsafeReplicate #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ {-# INLINE basicClear #-}+ {-# INLINE basicSet #-}+ {-# INLINE basicUnsafeCopy #-}+ {-# INLINE basicUnsafeGrow #-}+ basicLength (MV_IPv4 v) = MGVector.basicLength v+ basicUnsafeSlice i n (MV_IPv4 v) = MV_IPv4 $ MGVector.basicUnsafeSlice i n v+ basicOverlaps (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicOverlaps v1 v2+ basicUnsafeNew n = MV_IPv4 `liftM` MGVector.basicUnsafeNew n+ basicInitialize (MV_IPv4 v) = MGVector.basicInitialize v+ basicUnsafeReplicate n x = MV_IPv4 `liftM` MGVector.basicUnsafeReplicate n x+ basicUnsafeRead (MV_IPv4 v) i = MGVector.basicUnsafeRead v i+ basicUnsafeWrite (MV_IPv4 v) i x = MGVector.basicUnsafeWrite v i x+ basicClear (MV_IPv4 v) = MGVector.basicClear v+ basicSet (MV_IPv4 v) x = MGVector.basicSet v x+ basicUnsafeCopy (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicUnsafeCopy v1 v2+ basicUnsafeMove (MV_IPv4 v1) (MV_IPv4 v2) = MGVector.basicUnsafeMove v1 v2+ basicUnsafeGrow (MV_IPv4 v) n = MV_IPv4 `liftM` MGVector.basicUnsafeGrow v n++instance GVector.Vector UVector.Vector IPv4 where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ {-# INLINE elemseq #-}+ basicUnsafeFreeze (MV_IPv4 v) = V_IPv4 `liftM` GVector.basicUnsafeFreeze v+ basicUnsafeThaw (V_IPv4 v) = MV_IPv4 `liftM` GVector.basicUnsafeThaw v+ basicLength (V_IPv4 v) = GVector.basicLength v+ basicUnsafeSlice i n (V_IPv4 v) = V_IPv4 $ GVector.basicUnsafeSlice i n v+ basicUnsafeIndexM (V_IPv4 v) i = GVector.basicUnsafeIndexM v i+ basicUnsafeCopy (MV_IPv4 mv) (V_IPv4 v) = GVector.basicUnsafeCopy mv v+ elemseq _ = seq++instance ToJSON IPv4 where+ toJSON = Aeson.String . encode++instance FromJSON IPv4 where+ parseJSON = Aeson.withText "IPv4" aesonParser++instance ToJSONKey IPv4 where+ toJSONKey =+ ToJSONKeyText+ (keyFromText . encode)+ (\addr -> Aeson.unsafeToEncoding $ Builder.char7 '"' <> builderUtf8 addr <> Builder.char7 '"')+ where+#if MIN_VERSION_aeson(2,0,0)+ keyFromText = AesonKey.fromText+#else+ keyFromText = id+#endif++instance FromJSONKey IPv4 where+ fromJSONKey = FromJSONKeyTextParser aesonParser++aesonParser :: Text -> Aeson.Parser IPv4+aesonParser t = case decode t of+ Nothing -> fail "Could not parse IPv4 address"+ Just addr -> return addr++------------------------------------+-- Internal functions, not exported+------------------------------------++decodeIPv4TextMaybe :: Text -> Maybe IPv4+decodeIPv4TextMaybe t = case decodeIPv4TextReader t of+ Left _ -> Nothing+ Right (w, t') ->+ if Text.null t'+ then Just w+ else Nothing++decodeIPv4TextReader :: TextRead.Reader IPv4+decodeIPv4TextReader t1' = do+ (a, t2) <- readOctet t1'+ t2' <- stripDecimal t2+ (b, t3) <- readOctet t2'+ t3' <- stripDecimal t3+ (c, t4) <- readOctet t3'+ t4' <- stripDecimal t4+ (d, t5) <- readOctet t4'+ Right (fromOctets' a b c d, t5)++{- | Read an IPv4 octet (@0 <= n <= 255@)++The input must begin with at least one decimal digit. Input is consumed+until a non-digit is reached, the end of the input is reached, or the+accumulated value exceeds the maximum bound (255). As with+'TextRead.decimal', any number of leading zeros are permitted.++Optimizations:++* The 'Char.isDigit' and 'Char.digitToInt' functions are avoided in order+ to avoiding checking the range more than once. This implementation calls+ 'Char.ord' (once) and uses the result for both the range check and the+ calculation.+* The type of the accumulated value is 'Int', allowing for a single+ 'fromIntegral' call instead of one for each digit. This is possible+ because the maximum bound (255) is sufficiently less than the maximum+ bound of 'Int'. Specifically: @255 * 10 + Char.ord '9' <= maxBound@+* This implementation does not make use of @UnboxedTuples@ because the+ @span_@ function is part of the internal API. Additional performance+ could be gained by using this internal API function.+-}+readOctet :: TextRead.Reader Word+readOctet t = do+ let (digits, rest) = Text.span Char.isDigit t+ when (Text.null digits) $ Left "octet does not start with a digit"+ case Text.foldr go Just digits 0 of+ Just n -> Right (fromIntegral n, rest)+ Nothing -> Left ipOctetSizeErrorMsg+ where+ go :: Char -> (Int -> Maybe Int) -> Int -> Maybe Int+ go !d !f !n =+ let n' = n * 10 + Char.ord d - 48+ in if n' <= 255 then f n' else Nothing++stripDecimal :: Text -> Either String Text+stripDecimal t = case Text.uncons t of+ Nothing -> Left "expected a dot but input ended instead"+ Just (c, tnext) ->+ if c == '.'+ then Right tnext+ else Left "expected a dot but found a different character"++{- | This is sort of a misnomer. It takes Word to make+ dotDecimalParser perform better. This is mostly+ for internal use. The arguments must all fit+ in a Word8.+-}+fromOctets' :: Word -> Word -> Word -> Word -> IPv4+fromOctets' a b c d =+ IPv4 $+ fromIntegral+ ( shiftL a 24+ .|. shiftL b 16+ .|. shiftL c 8+ .|. d+ )++p24 :: Word32+p24 = getIPv4 (fromOctets' 10 0 0 0)++p20 :: Word32+p20 = getIPv4 (fromOctets' 172 16 0 0)++p16 :: Word32+p16 = getIPv4 (fromOctets' 192 168 0 0)++{- | This does not do an endOfInput check because it is+reused in the range parser implementation.+-}+dotDecimalParser :: AT.Parser IPv4+dotDecimalParser =+ fromOctets'+ <$> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ where+ limitSize i =+ if i > 255+ then fail ipOctetSizeErrorMsg+ else return i++ipOctetSizeErrorMsg :: String+ipOctetSizeErrorMsg = "All octets in an IPv4 address must be between 0 and 255"++toDotDecimalText :: IPv4 -> Text+toDotDecimalText = toTextPreAllocated++toDotDecimalBuilder :: IPv4 -> TBuilder.Builder+toDotDecimalBuilder = TBuilder.fromText . toTextPreAllocated++{- | I think that this function can be improved. Right now, it+ always allocates enough space for a fifteen-character text+ rendering of an IP address. I think that it should be possible+ to do more of the math upfront and allocate less space.+-}+toTextPreAllocated :: IPv4 -> Text+toTextPreAllocated (IPv4 w) =+ let w1 = 255 .&. unsafeShiftR (fromIntegral w) 24+ w2 = 255 .&. unsafeShiftR (fromIntegral w) 16+ w3 = 255 .&. unsafeShiftR (fromIntegral w) 8+ w4 = 255 .&. fromIntegral w+ in toTextPreallocatedPartTwo w1 w2 w3 w4++{- FOURMOLU_DISABLE -}+toTextPreallocatedPartTwo :: Word -> Word -> Word -> Word -> Text+toTextPreallocatedPartTwo !w1 !w2 !w3 !w4 =+#ifdef ghcjs_HOST_OS+ let dotStr = "."+ in Text.pack $ concat+ [ show w1+ , "."+ , show w2+ , "."+ , show w3+ , "."+ , show w4+ ]+#else+ let dot = 46+ (arr,len) = runST $ do+ marr <- TArray.new 15+ i1 <- putAndCount 0 w1 marr+ let n1 = i1+ n1' = i1 + 1+ TArray.unsafeWrite marr n1 dot+ i2 <- putAndCount n1' w2 marr+ let n2 = i2 + n1'+ n2' = n2 + 1+ TArray.unsafeWrite marr n2 dot+ i3 <- putAndCount n2' w3 marr+ let n3 = i3 + n2'+ n3' = n3 + 1+ TArray.unsafeWrite marr n3 dot+ i4 <- putAndCount n3' w4 marr+ theArr <- TArray.unsafeFreeze marr+ return (theArr,i4 + n3')+ in Text arr 0 len+#endif+{- FOURMOLU_ENABLE -}++twoDigits :: ByteString+twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99+{-# NOINLINE twoDigits #-}++threeDigits :: ByteString+threeDigits = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 999+{-# NOINLINE threeDigits #-}++i2w :: (Integral a) => a -> Codepoint+i2w v = zero + fromIntegral v++zero :: Codepoint+zero = 48++putAndCount :: Int -> Word -> TArray.MArray s -> ST s Int+putAndCount pos w marr+ | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1+ | w < 100 = write2 pos w >> return 2+ | otherwise = write3 pos w >> return 3+ where+ write2 off i0 = do+ let i = fromIntegral i0; j = i + i+ TArray.unsafeWrite marr off $ get2 j+ TArray.unsafeWrite marr (off + 1) $ get2 (j + 1)+ write3 off i0 = do+ let i = fromIntegral i0; j = i + i + i+ TArray.unsafeWrite marr off $ get3 j+ TArray.unsafeWrite marr (off + 1) $ get3 (j + 1)+ TArray.unsafeWrite marr (off + 2) $ get3 (j + 2)+ get2 = fromIntegral . ByteString.unsafeIndex twoDigits+ get3 = fromIntegral . ByteString.unsafeIndex threeDigits++rightToMaybe :: Either a b -> Maybe b+rightToMaybe = either (const Nothing) Just++{- $interoperability++The @<http://hackage.haskell.org/package/network network>@ 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@.+-}++{- $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.++>>> IPv4.printRange $ IPv4.fromBounds (IPv4.fromOctets 192 168 16 0) (IPv4.fromOctets 192 168 19 255)+192.168.16.0/22+>>> IPv4.printRange $ IPv4.fromBounds (IPv4.fromOctets 10 0 5 7) (IPv4.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 = IPv4.fromOctets 10 10 1 92+>>> IPv4.contains (IPv4.IPv4Range (IPv4.fromOctets 10 0 0 0) 8) ip+True+>>> IPv4.contains (IPv4.IPv4Range (IPv4.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 = IPv4.IPv4Range (IPv4.fromOctets 10 10 10 6) 31+>>> mapM_ (P.print . IPv4.contains r) (take 5 $ iterate succ $ IPv4.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++{- | Checks if the first range is a subset of the second range.++>>> IPv4.isSubsetOf (IPv4.IPv4Range (IPv4.fromOctets 192 0 2 128) 25) (IPv4.IPv4Range (IPv4.fromOctets 192 0 2 0) 24)+True+>>> IPv4.isSubsetOf (IPv4.IPv4Range (IPv4.fromOctets 192 0 2 0) 30) (IPv4.IPv4Range (IPv4.fromOctets 192 0 2 4) 30)+False+-}+isSubsetOf :: IPv4Range -> IPv4Range -> Bool+isSubsetOf a b =+ lowerInclusive a >= lowerInclusive b+ && upperInclusive a <= upperInclusive b++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> IPv4.member ip r == IPv4.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 $ IPv4.encode $ IPv4.lowerInclusive $ IPv4.IPv4Range (IPv4.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> IPv4.lowerInclusive r == IPv4.ipv4RangeBase (IPv4.normalize r)+-}+lowerInclusive :: IPv4Range -> IPv4+lowerInclusive (IPv4Range (IPv4 w) len) =+ IPv4 (w .&. mask len)++{- | The inclusive upper bound of an 'IPv4Range'.++ >>> T.putStrLn $ IPv4.encode $ IPv4.upperInclusive $ IPv4.IPv4Range (IPv4.ipv4 10 10 1 160) 25+ 10.10.1.255+-}+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 = IPv4.IPv4Range (IPv4.fromOctets 192 168 1 8) 30+>>> mapM_ (T.putStrLn . IPv4.encode) (IPv4.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++{- | A stream-polymorphic generator over an 'IPv4Range'.+ For more information, see <http://www.haskellforall.com/2014/11/how-to-build-library-agnostic-streaming.html How to build library-agnostic streaming sources>.+-}+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:++>>> IPv4.printRange $ IPv4.normalize $ IPv4.IPv4Range (IPv4.fromOctets 192 168 1 19) 24+192.168.1.0/24+>>> IPv4.printRange $ IPv4.normalize $ IPv4.IPv4Range (IPv4.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> IPv4.normalize r == (IPv4.normalize . IPv4.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 an 'IPv4Range' as 'Text'.++ >>> IPv4.encodeRange (IPv4.IPv4Range (IPv4.ipv4 172 16 0 0) 12)+ "172.16.0.0/12"+-}+encodeRange :: IPv4Range -> Text+encodeRange = rangeToDotDecimalText++{- | Decode an 'IPv4Range' from 'Text'.++ >>> IPv4.decodeRange "172.16.0.0/12"+ Just (IPv4Range {ipv4RangeBase = ipv4 172 16 0 0, ipv4RangeLength = 12})+ >>> IPv4.decodeRange "192.168.25.254/16"+ Just (IPv4Range {ipv4RangeBase = ipv4 192 168 0 0, ipv4RangeLength = 16})+-}+decodeRange :: Text -> Maybe IPv4Range+decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)++{- | Encode an 'IPv4Range' to a 'TBuilder.Builder'.++ >>> IPv4.builderRange (IPv4.IPv4Range (IPv4.ipv4 172 16 0 0) 12)+ "172.16.0.0/12"+-}+builderRange :: IPv4Range -> TBuilder.Builder+builderRange = rangeToDotDecimalBuilder++{- | Parse an 'IPv4Range' using a 'AT.Parser'.++ >>> AT.parseOnly IPv4.parserRange "192.168.25.254/16"+ Right (IPv4Range {ipv4RangeBase = ipv4 192 168 0 0, ipv4RangeLength = 16})+-}+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++{- | Print an 'IPv4Range'. Helper function that+ 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, Data)++instance NFData IPv4Range+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++-----------------+-- 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/IPv6.hs view
@@ -1,569 +1,1078 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE UnboxedTuples #-}--{-| This module provides the IPv6 data type and functions for working- with it.--}-module Net.IPv6- ( -- * Convert- ipv6- , fromOctets- , fromWord16s- , fromWord32s- , fromTupleWord16s- , fromTupleWord32s- , toWord16s- , toWord32s- -- * Special IP Addresses- , any- , loopback- , localhost- -- * Textual Conversion- -- ** Text- , encode- , decode- , 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(..))-import qualified Net.IPv4 as IPv4--import Control.Applicative-import Control.DeepSeq (NFData)-import Data.Bits-import Data.Char (chr)-import Data.List (intercalate, group)-import Data.Primitive.Types (Prim)-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup ((<>))-#endif-import qualified Data.Aeson as Aeson-import qualified Data.Attoparsec.Text as AT-import qualified Data.Attoparsec.Text as Atto-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.IO as TIO-import Data.WideWord.Word128 (Word128(..), zeroWord128)-import Data.Word-import Foreign.Storable (Storable)-import GHC.Exts-import GHC.Generics (Generic)-import Numeric (showHex)-import Prelude hiding (any, print)-import Text.ParserCombinators.ReadPrec (prec,step)-import Text.Read (Read(..),Lexeme(Ident),lexP,parens)---- $setup------ These are here to get doctest work.------ >>> import qualified Prelude as P--- >>> import qualified Data.Text.IO as T--- >>> import Test.QuickCheck (Arbitrary(..))--- >>> instance Arbitrary Word128 where { arbitrary = Word128 <$> arbitrary <*> arbitrary }--- >>> instance Arbitrary IPv6 where { arbitrary = IPv6 <$> arbitrary }--- >>> instance Arbitrary IPv6Range where { arbitrary = IPv6Range <$> arbitrary <*> arbitrary }------- | A 128-bit Internet Protocol version 6 address.-newtype IPv6 = IPv6 { getIPv6 :: Word128 }- deriving (Bounded,Enum,Eq,Integral,Num,Ord,Real,Storable,Bits,FiniteBits,NFData,Prim)--instance Show IPv6 where- showsPrec p addr = showParen (p > 10)- $ showString "ipv6 "- . showHexWord16 a- . showChar ' '- . showHexWord16 b- . showChar ' '- . showHexWord16 c- . showChar ' '- . showHexWord16 d- . showChar ' '- . showHexWord16 e- . showChar ' '- . showHexWord16 f- . showChar ' '- . showHexWord16 g- . showChar ' '- . showHexWord16 h- where- (a,b,c,d,e,f,g,h) = toWord16s addr---- | Print an 'IPv6' using the textual encoding.-print :: IPv6 -> IO ()-print = TIO.putStrLn . encode--showHexWord16 :: Word16 -> ShowS-showHexWord16 w =- showString "0x"- . showChar (nibbleToHex (unsafeShiftR (fromIntegral w) 12))- . showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) 8) .&. 0xF))- . showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) 4) .&. 0xF))- . showChar (nibbleToHex ((fromIntegral w) .&. 0xF))---- invariant: argument must be less than 16-nibbleToHex :: Word -> Char-nibbleToHex w- | w < 10 = chr (fromIntegral (w + 48))- | otherwise = chr (fromIntegral (w + 87))--instance Read IPv6 where- readPrec = parens $ prec 10 $ do- Ident "ipv6" <- lexP- a <- step readPrec- b <- step readPrec- c <- step readPrec- d <- step readPrec- e <- step readPrec- f <- step readPrec- g <- step readPrec- h <- step readPrec- return (fromWord16s a b c d e f g h)--instance Aeson.ToJSON IPv6 where- toJSON = Aeson.String . encode--instance Aeson.FromJSON IPv6 where- parseJSON = Aeson.withText "IPv6" $ \t -> case decode t of- Nothing -> fail "invalid IPv6 address"- Just i -> return i--rightToMaybe :: Either a b -> Maybe b-rightToMaybe = either (const Nothing) Just---- | This could be useful for the rare occasion--- in which one could construct an 'IPv6' from--- octets.------ Note that while @Net.IPv4.'Net.IPv4.fromOctets' = Net.IPv4.'Net.IPv4.ipv4'@,--- @Net.IPv6.fromOctets /= Net.IPv6.ipv6@. While this should be obvious--- from their types, it is worth mentioning since the similarity in naming--- might be confusing.-fromOctets ::- Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> IPv6-fromOctets a b c d e f g h i j k l m n o p =- IPv6 $ fromOctetsWord128- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)- (fromIntegral e) (fromIntegral f) (fromIntegral g) (fromIntegral h)- (fromIntegral i) (fromIntegral j) (fromIntegral k) (fromIntegral l)- (fromIntegral m) (fromIntegral n) (fromIntegral o) (fromIntegral p)--fromOctetsWord128 ::- Word128 -> Word128 -> Word128 -> Word128- -> Word128 -> Word128 -> Word128 -> Word128- -> Word128 -> Word128 -> Word128 -> Word128- -> Word128 -> Word128 -> Word128 -> Word128- -> Word128-fromOctetsWord128 a b c d e f g h i j k l m n o p = fromIntegral- ( shiftL a 120- .|. shiftL b 112- .|. shiftL c 104- .|. shiftL d 96- .|. shiftL e 88- .|. shiftL f 80- .|. shiftL g 72- .|. shiftL h 64- .|. shiftL i 56- .|. shiftL j 48- .|. shiftL k 40- .|. shiftL l 32- .|. shiftL m 24- .|. shiftL n 16- .|. shiftL o 8- .|. p- )---- | Create an 'IPv6' address from the eight 16-bit fragments that make--- it up. This closely resembles the standard IPv6 notation, so--- is used for the 'Show' instance. Note that this lacks the formatting--- feature for suppress zeroes in an 'IPv6' address, but it should be--- readable enough for hacking in GHCi.------ >>> let addr = ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1--- >>> addr--- ipv6 0x3124 0x0000 0x0000 0xdead 0xcafe 0x00ff 0xfe00 0x0001--- >>> T.putStrLn (encode addr)--- 3124::dead:cafe:ff:fe00:1-ipv6 ::- Word16 -> Word16 -> Word16 -> Word16- -> Word16 -> Word16 -> Word16 -> Word16- -> IPv6-ipv6 = fromWord16s---- | An alias for the 'ipv6' smart constructor.-fromWord16s ::- Word16 -> Word16 -> Word16 -> Word16- -> Word16 -> Word16 -> Word16 -> Word16- -> IPv6-fromWord16s a b c d e f g h =- IPv6 $ fromWord16sWord128- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)- (fromIntegral e) (fromIntegral f) (fromIntegral g) (fromIntegral h)--fromWord16sWord128 ::- Word128 -> Word128 -> Word128 -> Word128- -> Word128 -> Word128 -> Word128 -> Word128- -> Word128-fromWord16sWord128 a b c d e f g h = fromIntegral- ( shiftL a 112- .|. shiftL b 96- .|. shiftL c 80- .|. shiftL d 64- .|. shiftL e 48- .|. shiftL f 32- .|. shiftL g 16- .|. h- )---- | Convert an 'IPv6' to eight 16-bit words.-toWord16s :: IPv6 -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16)-toWord16s (IPv6 (Word128 a b)) =- -- Note: implementing this as 2 Word64 shifts with 'unsafeShiftR'- -- is up to 40% faster than using 128-bit shifts on a Word128 value.- ( fromIntegral (unsafeShiftR a 48)- , fromIntegral (unsafeShiftR a 32)- , fromIntegral (unsafeShiftR a 16)- , fromIntegral a- , fromIntegral (unsafeShiftR b 48)- , fromIntegral (unsafeShiftR b 32)- , fromIntegral (unsafeShiftR b 16)- , fromIntegral b- )---- | Uncurried variant of 'fromWord16s'.-fromTupleWord16s :: (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16) -> IPv6-fromTupleWord16s (a,b,c,d,e,f,g,h) = fromWord16s a b c d e f g h---- | Build an 'IPv6' from four 32-bit words. The leftmost argument--- is the high word and the rightword is the low word.-fromWord32s :: Word32 -> Word32 -> Word32 -> Word32 -> IPv6-fromWord32s a b c d =- IPv6 $ fromWord32sWord128- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)--fromWord32sWord128 ::- Word128 -> Word128 -> Word128 -> Word128- -> Word128-fromWord32sWord128 a b c d = fromIntegral- ( shiftL a 96- .|. shiftL b 64- .|. shiftL c 32- .|. d- )---- | Uncurried variant of 'fromWord32s'.-fromTupleWord32s :: (Word32,Word32,Word32,Word32) -> IPv6-fromTupleWord32s (a,b,c,d) = fromWord32s a b c d---- | Convert an 'IPv6' to four 32-bit words.-toWord32s :: IPv6 -> (Word32,Word32,Word32,Word32)-toWord32s (IPv6 (Word128 a b)) =- -- Note: implementing this as 2 Word64 shifts with 'unsafeShiftR'- -- is about 10% faster than using 128-bit shifts on a Word128 value.- ( fromIntegral (unsafeShiftR a 32)- , fromIntegral a- , fromIntegral (unsafeShiftR b 32)- , fromIntegral b- )---- | The local loopback IP address.------ >>> loopback--- ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001-loopback :: IPv6-loopback = IPv6 (Word128 0 1)---- | A useful alias for 'loopback'.------ >>> localhost--- ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001-localhost :: IPv6-localhost = loopback---- | The IP address representing any host.------ >>> any--- ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000-any :: IPv6-any = IPv6 zeroWord128---- | Encodes the IP, using zero-compression on the leftmost-longest string of--- zeroes in the address.--- Per <https://tools.ietf.org/html/rfc5952#section-5 RFC 5952 Section 5>,--- this uses mixed notation when encoding an IPv4-mapped IPv6 address:------ >>> T.putStrLn $ encode $ fromWord16s 0xDEAD 0xBEEF 0x0 0x0 0x0 0x0 0x0 0x1234--- dead:beef::1234--- >>> T.putStrLn $ encode $ fromWord16s 0x0 0x0 0x0 0x0 0x0 0xFFFF 0x6437 0xA5B4--- ::ffff:100.55.165.180--- >>> T.putStrLn $ encode $ fromWord16s 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0x0--- ::-encode :: IPv6 -> Text-encode ip =- if isIPv4MappedAddress- -- This representation is RECOMMENDED by https://tools.ietf.org/html/rfc5952#section-5- then Text.pack "::ffff:" `mappend` IPv4.encode (IPv4.IPv4 (fromIntegral w7 `unsafeShiftL` 16 .|. fromIntegral w8))- else toText [w1, w2, w3, w4, w5, w6, w7, w8]- where- isIPv4MappedAddress = w1 == 0 && w2 == 0 && w3 == 0 && w4 == 0 && w5 == 0 && w6 == 0xFFFF- (w1, w2, w3, w4, w5, w6, w7, w8) = toWord16s ip- toText ws = Text.pack $ intercalate ":" $ expand 0 longestZ grouped- where- expand _ 8 _ = ["::"]- expand _ _ [] = []- expand i longest ((x, len):wsNext)- -- zero-compressed group:- | x == 0 && len == longest =- -- first and last need an extra colon since there's nothing- -- to concat against- (if i == 0 || (i+len) == 8 then ":" else "")- : expand (i+len) 0 wsNext- -- normal group:- | otherwise = replicate len (showHex x "") ++ expand (i+len) longest wsNext- longestZ = maximum . (0:) . map snd . filter ((==0) . fst) $ grouped- grouped = map (\x -> (head x, length x)) (group ws)---- | Decode an IPv6 address. This accepts both standard IPv6--- notation (with zero compression) and mixed notation for--- IPv4-mapped IPv6 addresses.-decode :: Text -> Maybe IPv6-decode t = rightToMaybe (AT.parseOnly (parser <* AT.endOfInput) t)---- | Parse an 'IPv6' using 'Atto.Parser'.------ >>> ip = ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B--- >>> Atto.parseOnly parser (Text.pack "dead:beef:3240:a426:ba68:1cd0:4263:109b")--- Right (ipv6 0xdead 0xbeef 0x3240 0xa426 0xba68 0x1cd0 0x4263 0x109b)-parser :: Atto.Parser IPv6-parser = makeIP <$> ip- where- 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."-- ip = (Atto.char ':' *> Atto.char ':' *> doubleColon 0) <|> part 0-- 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)- )- )-- 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)-- -- 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)]---- | An 'IPv6Range'. It is made up of the first 'IPv6' in the range--- and its length.-data IPv6Range = IPv6Range- { ipv6RangeBase :: {-# UNPACK #-} !IPv6- , ipv6RangeLength :: {-# UNPACK #-} !Word8- } deriving (Eq,Ord,Show,Read,Generic)--instance NFData IPv6Range--mask128 :: IPv6-mask128 = maxBound--mask :: Word8 -> IPv6-mask = complement . shiftR mask128 . fromIntegral---- | Normalize an 'IPv6Range'. The first result of this is that the--- 'IPv6' inside the 'IPv6Range' is changed so that the insignificant--- bits are zeroed out. For example:------ >>> addr1 = ipv6 0x0192 0x0168 0x0001 0x0019 0x0000 0x0000 0x0000 0x0000--- >>> addr2 = ipv6 0x0192 0x0168 0x0001 0x0163 0x0000 0x0000 0x0000 0x0000--- >>> printRange $ normalize $ IPv6Range addr1 24--- 192:100::/24--- >>> printRange $ normalize $ IPv6Range addr2 28--- 192:160::/28------ The second effect of this is that the mask length is lowered to be 128--- or smaller. Working with 'IPv6Range'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 128).------ Note that 'normalize is idempotent, that is:------ prop> normalize r == (normalize . normalize) r-normalize :: IPv6Range -> IPv6Range-normalize (IPv6Range ip len) =- let len' = min len 128- ip' = ip .&. mask len'- in IPv6Range ip' len'---- | Encode an 'IPv6Range' as 'Text'.------ >>> addr = ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B--- >>> T.putStrLn $ encodeRange $ IPv6Range addr 28--- dead:beef:3240:a426:ba68:1cd0:4263:109b/28-encodeRange :: IPv6Range -> Text-encodeRange x = encode (ipv6RangeBase x) <> Text.pack "/" <> (Text.pack $ (show . fromEnum) $ ipv6RangeLength x)---- | Decode an 'IPv6Range' from 'Text'.------ >>> addr = ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B--- >>> fmap encodeRange $ decodeRange (Text.pack "dead:beef:3240:a426:ba68:1cd0:4263:109b/28")--- Just "dead:bee0::/28"-decodeRange :: Text -> Maybe IPv6Range-decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)---- | Parse an 'IPv6Range' using a 'AT.Parser'.-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 subnet len) =- let theMask = mask len- subnetNormalized = subnet .&. theMask- in \ip -> (ip .&. theMask) == subnetNormalized---- | 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 'IPv6Range' is simply the--- ip address of the range:------ prop> lowerInclusive r == ipv6RangeBase (normalize r)-lowerInclusive :: IPv6Range -> IPv6-lowerInclusive = ipv6RangeBase . normalize---- | The inclusive upper bound of an 'IPv6Range'.------ >>> let addr = ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B--- >>> T.putStrLn $ encode $ upperInclusive $ IPv6Range addr 25--- dead:beff:ffff:ffff:ffff:ffff:ffff:ffff----upperInclusive :: IPv6Range -> IPv6-upperInclusive (IPv6Range ip len) =- let len' = min 128 len- theInvertedMask :: IPv6- theInvertedMask = shiftR mask128 (fromIntegral len')- in ip .|. theInvertedMask---- | Print an 'IPv6Range' using the textual encoding.-printRange :: IPv6Range -> IO ()-printRange = TIO.putStrLn . encodeRange---- | Smart constructor for 'IPv6Range'. Ensures the mask is appropriately--- sized and sets masked bits in the 'IPv6' to zero.------ >>> let addr = ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B--- >>> printRange $ range addr 25--- dead:be80::/25-range :: IPv6 -> Word8 -> IPv6Range-range addr len = normalize (IPv6Range addr len)---- | Given an inclusive lower and upper ip address, create the smallest 'IPv6Range'--- that contains the two. This is helpful in situations where input is given as a--- range, like @ @.------ This makes the range broader if it cannot be represented in <https://en.wikipedia.org/wiki/Classless_Inter-Domain_Routing CIDR> notation.------ >>> addrLower = ipv6 0xDEAD 0xBE80 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000--- >>> addrUpper = ipv6 0xDEAD 0xBEFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF--- >>> printRange $ fromBounds addrLower addrUpper--- dead:be80::/25+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}++{- | This module provides the IPv6 data type and functions for working+ with it.+-}+module Net.IPv6+ ( -- * Convert+ ipv6+ , fromOctets+ , fromWord16s+ , fromWord32s+ , fromTupleWord16s+ , fromTupleWord32s+ , toWord16s+ , toWord32s++ -- * Special IP Addresses+ , any+ , loopback+ , localhost++ -- * Textual Conversion++ -- ** Text+ , encode+ , encodeShort+ , decode+ , decodeShort+ , parser++ -- * UTF-8 Bytes+ , parserUtf8Bytes+ , decodeUtf8Bytes+ , boundedBuilderUtf8++ -- ** Printing+ , print++ -- * IPv6 Ranges++ -- ** Range functions+ , range+ , fromBounds+ , normalize+ , contains+ , isSubsetOf+ , member+ , lowerInclusive+ , upperInclusive++ -- ** Textual Conversion++ -- *** Text+ , encodeRange+ , decodeRange+ , parserRange+ , printRange++ -- ** UTF-8 Bytes+ , parserRangeUtf8Bytes+ , parserRangeUtf8BytesLenient++ -- * Types+ , IPv6 (..)+ , IPv6Range (..)+ ) where++import Prelude hiding (any, print)++import Net.IPv4 (IPv4 (..))++import Control.Applicative+import Control.DeepSeq (NFData)+import Control.Monad (mzero)+import Control.Monad.ST (ST)+import Data.Bits+import Data.Char (chr)+import Data.Data (Data)+import Data.Hashable (Hashable, hashWithSalt)+import Data.Ix (Ix)+import Data.List (group, intercalate)+import Data.Primitive (MutablePrimArray)+import Data.Primitive.Types (Prim)+import Data.Text (Text)+import Data.Text.Short (ShortText)+import Data.WideWord.Word128 (Word128 (..), zeroWord128)+import Data.Word+import Foreign.Storable (Storable)+import GHC.Exts (Int (I#), Int#, Word#)+import GHC.Generics (Generic)+import Numeric (showHex)+import Text.ParserCombinators.ReadPrec (prec, step)+import Text.Read (Lexeme (Ident), Read (..), lexP, parens)++import qualified Arithmetic.Lte as Lte+import qualified Arithmetic.Nat as Nat+import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.Text as AT+import qualified Data.Attoparsec.Text as Atto+import qualified Data.ByteString.Short.Internal as BSS+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Builder.Bounded as BB+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Primitive as PM+import qualified Data.Text as Text+import qualified Data.Text.IO as TIO+import qualified Data.Text.Short as TS+import qualified Data.Text.Short.Unsafe as TS+import qualified GHC.Word.Compat as Compat+import qualified Net.IPv4 as IPv4++{- $setup++These are here to get doctest work.++>>> import qualified Prelude as P+>>> import qualified Data.Text.IO as T+>>> import qualified Data.Text as Text+>>> import qualified Data.Attoparsec.Text as Atto+>>> import qualified Data.Bytes.Text.Ascii as Ascii+>>> import Test.QuickCheck (Arbitrary(..))+>>> instance Arbitrary Word128 where { arbitrary = Word128 <$> arbitrary <*> arbitrary }+>>> instance Arbitrary IPv6 where { arbitrary = IPv6 <$> arbitrary }+>>> instance Arbitrary IPv6.IPv6Range where { arbitrary = IPv6.IPv6Range <$> arbitrary <*> arbitrary }+-}++-- | A 128-bit Internet Protocol version 6 address.+newtype IPv6 = IPv6 {getIPv6 :: Word128}+ deriving (Bounded, Enum, Eq, Ord, Storable, Bits, FiniteBits, NFData, Prim, Ix, Data, Generic)++instance Hashable IPv6 where+ hashWithSalt s (IPv6 (Word128 a b)) = hashWithSalt (hashWithSalt s a) b++instance Show IPv6 where+ showsPrec p addr =+ showParen (p > 10) $+ showString "ipv6 "+ . showHexWord16 a+ . showChar ' '+ . showHexWord16 b+ . showChar ' '+ . showHexWord16 c+ . showChar ' '+ . showHexWord16 d+ . showChar ' '+ . showHexWord16 e+ . showChar ' '+ . showHexWord16 f+ . showChar ' '+ . showHexWord16 g+ . showChar ' '+ . showHexWord16 h+ where+ (a, b, c, d, e, f, g, h) = toWord16s addr++-- | Print an 'IPv6' using the textual encoding.+print :: IPv6 -> IO ()+print = TIO.putStrLn . encode++{- | Decode 'ShortText' as an 'IPv6' address.++ >>> decodeShort "ffff::2:b"+ Just (ipv6 0xffff 0x0000 0x0000 0x0000 0x0000 0x0000 0x0002 0x000b)+-}+decodeShort :: ShortText -> Maybe IPv6+decodeShort t = decodeUtf8Bytes (Bytes.fromByteArray b)+ where+ b = shortByteStringToByteArray (TS.toShortByteString t)++shortByteStringToByteArray :: BSS.ShortByteString -> PM.ByteArray+shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x++showHexWord16 :: Word16 -> ShowS+showHexWord16 w =+ showString "0x"+ . showChar (nibbleToHex (unsafeShiftR (fromIntegral w) 12))+ . showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) 8) .&. 0xF))+ . showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) 4) .&. 0xF))+ . showChar (nibbleToHex ((fromIntegral w) .&. 0xF))++-- invariant: argument must be less than 16+nibbleToHex :: Word -> Char+nibbleToHex w+ | w < 10 = chr (fromIntegral (w + 48))+ | otherwise = chr (fromIntegral (w + 87))++instance Read IPv6 where+ readPrec = parens $ prec 10 $ do+ Ident "ipv6" <- lexP+ a <- step readPrec+ b <- step readPrec+ c <- step readPrec+ d <- step readPrec+ e <- step readPrec+ f <- step readPrec+ g <- step readPrec+ h <- step readPrec+ return (fromWord16s a b c d e f g h)++instance Aeson.ToJSON IPv6 where+ toJSON = Aeson.String . encode++instance Aeson.FromJSON IPv6 where+ parseJSON = Aeson.withText "IPv6" $ \t -> case decode t of+ Nothing -> fail "invalid IPv6 address"+ Just i -> return i++rightToMaybe :: Either a b -> Maybe b+rightToMaybe = either (const Nothing) Just++{- | This could be useful for the rare occasion+ in which one could construct an 'IPv6' from+ octets.++ Note that while @Net.IPv4.'Net.IPv4.fromOctets' = Net.IPv4.'Net.IPv4.ipv4'@,+ @Net.IPv6.fromOctets /= Net.IPv6.ipv6@. While this should be obvious+ from their types, it is worth mentioning since the similarity in naming+ might be confusing.+-}+fromOctets ::+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ Word8 ->+ IPv6+fromOctets a b c d e f g h i j k l m n o p =+ IPv6 $+ fromOctetsWord128+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)+ (fromIntegral e)+ (fromIntegral f)+ (fromIntegral g)+ (fromIntegral h)+ (fromIntegral i)+ (fromIntegral j)+ (fromIntegral k)+ (fromIntegral l)+ (fromIntegral m)+ (fromIntegral n)+ (fromIntegral o)+ (fromIntegral p)++fromOctetsWord128 ::+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128+fromOctetsWord128 a b c d e f g h i j k l m n o p =+ fromIntegral+ ( shiftL a 120+ .|. shiftL b 112+ .|. shiftL c 104+ .|. shiftL d 96+ .|. shiftL e 88+ .|. shiftL f 80+ .|. shiftL g 72+ .|. shiftL h 64+ .|. shiftL i 56+ .|. shiftL j 48+ .|. shiftL k 40+ .|. shiftL l 32+ .|. shiftL m 24+ .|. shiftL n 16+ .|. shiftL o 8+ .|. p+ )++{- | Create an 'IPv6' address from the eight 16-bit fragments that make+ it up. This closely resembles the standard IPv6 notation, so+ is used for the 'Show' instance. Note that this lacks the formatting+ feature for suppress zeroes in an 'IPv6' address, but it should be+ readable enough for hacking in GHCi.++ >>> let addr = ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1+ >>> addr+ ipv6 0x3124 0x0000 0x0000 0xdead 0xcafe 0x00ff 0xfe00 0x0001+ >>> T.putStrLn (encode addr)+ 3124::dead:cafe:ff:fe00:1+-}+ipv6 ::+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ IPv6+ipv6 = fromWord16s++-- | An alias for the 'ipv6' smart constructor.+fromWord16s ::+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ IPv6+fromWord16s a b c d e f g h =+ IPv6 $+ fromWord16sWord128+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)+ (fromIntegral e)+ (fromIntegral f)+ (fromIntegral g)+ (fromIntegral h)++fromWord16sWord128 ::+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128+fromWord16sWord128 a b c d e f g h =+ fromIntegral+ ( shiftL a 112+ .|. shiftL b 96+ .|. shiftL c 80+ .|. shiftL d 64+ .|. shiftL e 48+ .|. shiftL f 32+ .|. shiftL g 16+ .|. h+ )++-- | Convert an 'IPv6' to eight 16-bit words.+toWord16s :: IPv6 -> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)+toWord16s (IPv6 (Word128 a b)) =+ -- Note: implementing this as 2 Word64 shifts with 'unsafeShiftR'+ -- is up to 40% faster than using 128-bit shifts on a Word128 value.+ ( fromIntegral (unsafeShiftR a 48)+ , fromIntegral (unsafeShiftR a 32)+ , fromIntegral (unsafeShiftR a 16)+ , fromIntegral a+ , fromIntegral (unsafeShiftR b 48)+ , fromIntegral (unsafeShiftR b 32)+ , fromIntegral (unsafeShiftR b 16)+ , fromIntegral b+ )++-- | Uncurried variant of 'fromWord16s'.+fromTupleWord16s :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> IPv6+fromTupleWord16s (a, b, c, d, e, f, g, h) = fromWord16s a b c d e f g h++{- | Build an 'IPv6' from four 32-bit words. The leftmost argument+ is the high word and the rightword is the low word.+-}+fromWord32s :: Word32 -> Word32 -> Word32 -> Word32 -> IPv6+fromWord32s a b c d =+ IPv6 $+ fromWord32sWord128+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)++fromWord32sWord128 ::+ Word128 ->+ Word128 ->+ Word128 ->+ Word128 ->+ Word128+fromWord32sWord128 a b c d =+ fromIntegral+ ( shiftL a 96+ .|. shiftL b 64+ .|. shiftL c 32+ .|. d+ )++-- | Uncurried variant of 'fromWord32s'.+fromTupleWord32s :: (Word32, Word32, Word32, Word32) -> IPv6+fromTupleWord32s (a, b, c, d) = fromWord32s a b c d++-- | Convert an 'IPv6' to four 32-bit words.+toWord32s :: IPv6 -> (Word32, Word32, Word32, Word32)+toWord32s (IPv6 (Word128 a b)) =+ -- Note: implementing this as 2 Word64 shifts with 'unsafeShiftR'+ -- is about 10% faster than using 128-bit shifts on a Word128 value.+ ( fromIntegral (unsafeShiftR a 32)+ , fromIntegral a+ , fromIntegral (unsafeShiftR b 32)+ , fromIntegral b+ )++{- | The local loopback IP address.++ >>> IPv6.loopback+ ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001+-}+loopback :: IPv6+loopback = IPv6 (Word128 0 1)++{- | A useful alias for 'loopback'.++ >>> IPv6.localhost+ ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001+-}+localhost :: IPv6+localhost = loopback++{- | The IP address representing any host.++ >>> IPv6.any+ ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000+-}+any :: IPv6+any = IPv6 zeroWord128++{- | Encodes the 'IPv6' address using zero-compression on the leftmost longest+string of zeroes in the address.+Per <https://tools.ietf.org/html/rfc5952#section-5 RFC 5952 Section 5>,+this uses mixed notation when encoding an IPv4-mapped IPv6 address:++>>> T.putStrLn $ IPv6.encode $ IPv6.fromWord16s 0xDEAD 0xBEEF 0x0 0x0 0x0 0x0 0x0 0x1234+dead:beef::1234+>>> T.putStrLn $ IPv6.encode $ IPv6.fromWord16s 0x0 0x0 0x0 0x0 0x0 0xFFFF 0x6437 0xA5B4+::ffff:100.55.165.180+>>> T.putStrLn $ IPv6.encode $ IPv6.fromWord16s 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0x0+::++Per <https://tools.ietf.org/html/rfc5952#section-4.2.2 Section 4.2.2> of the+same RFC, this does not use @::@ to shorten a single 16-bit 0 field. Only+runs of multiple 0 fields are considered.+-}+encode :: IPv6 -> Text+encode !ip =+ -- TODO: This implementation, while correct, is not particularly efficient.+ -- It uses string all over the place.+ if isIPv4Mapped ip+ then -- This representation is RECOMMENDED by https://tools.ietf.org/html/rfc5952#section-5++ Text.pack "::ffff:"+ `mappend` IPv4.encode (IPv4.IPv4 (fromIntegral w7 `unsafeShiftL` 16 .|. fromIntegral w8))+ else toText [w1, w2, w3, w4, w5, w6, w7, w8]+ where+ (w1, w2, w3, w4, w5, w6, w7, w8) = toWord16s ip+ toText ws =+ Text.pack $+ intercalate ":" $+ expand 0 (if longestZ > 1 then longestZ else 0) grouped+ where+ expand !_ 8 !_ = ["::"]+ expand !_ !_ [] = []+ expand !i !longest ((x, len) : wsNext)+ -- zero-compressed group:+ | x == 0 && len == longest =+ -- first and last need an extra colon since there's nothing+ -- to concat against+ (if i == 0 || (i + len) == 8 then ":" else "")+ : expand (i + len) 0 wsNext+ -- normal group:+ | otherwise = replicate len (showHex x "") ++ expand (i + len) longest wsNext+ longestZ = maximum . (0 :) . map snd . filter ((== 0) . fst) $ grouped+ grouped = map (\x -> (head x, length x)) (group ws)++isIPv4Mapped :: IPv6 -> Bool+isIPv4Mapped (IPv6 (Word128 w1 w2)) =+ w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000)++{- | Decode UTF-8-encoded 'Bytes' into an 'IPv6' address.++ >>> decodeUtf8Bytes (Ascii.fromString "::cab:1")+ Just (ipv6 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0cab 0x0001)+-}+decodeUtf8Bytes :: Bytes.Bytes -> Maybe IPv6+decodeUtf8Bytes !b = case Parser.parseBytes (parserUtf8Bytes ()) b of+ Parser.Success (Parser.Slice _ len addr) -> case len of+ 0 -> Just addr+ _ -> Nothing+ Parser.Failure _ -> Nothing++{- | Encodes the 'IPv6' address using zero-compression on the+leftmost longest string of zeroes in the address.++>>> BB.run Nat.constant $ IPv6.boundedBuilderUtf8 $ IPv6.fromWord16s 0xDEAD 0xBEEF 0x0 0x0 0x0 0x0 0x0 0x1234+[0x64, 0x65, 0x61, 0x64, 0x3a, 0x62, 0x65, 0x65, 0x66, 0x3a, 0x3a, 0x31, 0x32, 0x33, 0x34]+-}+boundedBuilderUtf8 :: IPv6 -> BB.Builder 39+boundedBuilderUtf8 !ip@(IPv6 (Word128 hi lo))+ | hi == 0 && lo == 0 =+ BB.weaken+ Lte.constant+ (BB.ascii ':' `BB.append` BB.ascii ':')+ | isIPv4Mapped ip =+ BB.weaken Lte.constant $+ BB.ascii ':'+ `BB.append` BB.ascii ':'+ `BB.append` BB.ascii 'f'+ `BB.append` BB.ascii 'f'+ `BB.append` BB.ascii 'f'+ `BB.append` BB.ascii 'f'+ `BB.append` BB.ascii ':'+ `BB.append` IPv4.boundedBuilderUtf8 (IPv4.IPv4 (fromIntegral lo))+ | otherwise =+ let (w0, w1, w2, w3, w4, w5, w6, w7) = toWord16s ip+ IntTriple startLongest longest _ = longestRun w0 w1 w2 w3 w4 w5 w6 w7+ start = startLongest+ end = start + longest+ in -- start is inclusive. end is exclusive+ firstPiece w0 start+ `BB.append` piece 1 w1 start end+ `BB.append` piece 2 w2 start end+ `BB.append` piece 3 w3 start end+ `BB.append` piece 4 w4 start end+ `BB.append` piece 5 w5 start end+ `BB.append` piece 6 w6 start end+ `BB.append` lastPiece w7 end++firstPiece :: Word16 -> Int -> BB.Builder 4+firstPiece !w !start = case start of+ 0 -> BB.weaken Lte.constant (BB.ascii ':')+ _ -> BB.word16LowerHex w++-- Note about the implementation of piece:+-- It is important to manually perform worker-wrapper so that+-- we can stop piece from inlining. If we do not do this, GHC+-- inlines piece, leading to enormous blowup in the generated+-- Core. The implementation of boundedBuilderUtf8 becomes+-- thousands of lines of Core. Even in the microbenchmark that+-- comes with this library, it can be observed that preventing+-- this inlining improves performance of encodeShort by 50%.+piece :: Int -> Word16 -> Int -> Int -> BB.Builder 5+{-# INLINE piece #-}+piece (I# ix) (Compat.W16# w) (I# start) (I# end) =+ piece# ix w start end++piece# :: Int# -> Word# -> Int# -> Int# -> BB.Builder 5+{-# NOINLINE piece# #-}+piece# !ix# !w# !start# !end# = case compare ix start of+ LT -> BB.ascii ':' `BB.append` BB.word16LowerHex w+ EQ -> BB.weaken Lte.constant (BB.ascii ':')+ GT ->+ if ix < end+ then BB.weaken Lte.constant BB.empty+ else BB.ascii ':' `BB.append` BB.word16LowerHex w+ where+ ix = I# ix#+ start = I# start#+ end = I# end#+ w = Compat.W16# w#++lastPiece :: Word16 -> Int -> BB.Builder 5+lastPiece !w !end = case end of+ 8 -> BB.weaken Lte.constant (BB.ascii ':')+ _ -> BB.ascii ':' `BB.append` BB.word16LowerHex w++data IntTriple = IntTriple !Int !Int !Int++-- Choose the longest run. Prefer the leftmost run in the+-- event of a tie.+stepZeroRunLength :: Int -> Word16 -> IntTriple -> IntTriple+stepZeroRunLength !ix !w (IntTriple startLongest longest current) = case w of+ 0 ->+ let !x = current + 1+ in if x > longest+ then IntTriple (ix - current) x x+ else IntTriple startLongest longest x+ _ -> IntTriple startLongest longest 0++-- We start out by setting the longest run to size 1. This+-- means that we will only detect runs of length two or greater.+longestRun ::+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ Word16 ->+ IntTriple+longestRun !w0 !w1 !w2 !w3 !w4 !w5 !w6 !w7 =+ id $+ stepZeroRunLength 7 w7 $+ stepZeroRunLength 6 w6 $+ stepZeroRunLength 5 w5 $+ stepZeroRunLength 4 w4 $+ stepZeroRunLength 3 w3 $+ stepZeroRunLength 2 w2 $+ stepZeroRunLength 1 w1 $+ stepZeroRunLength 0 w0 $+ IntTriple (-1) 1 0++{- | Encodes the 'IPv6' address as 'ShortText' using zero-compression on+the leftmost longest string of zeroes in the address.+Per <https://tools.ietf.org/html/rfc5952#section-5 RFC 5952 Section 5>,+this uses mixed notation when encoding an IPv4-mapped IPv6 address.++>>> IPv6.encodeShort $ IPv6.fromWord16s 0xDEAD 0xBEEF 0x0 0x0 0x0 0x0ABC 0x0 0x1234+"dead:beef::abc:0:1234"+-}+encodeShort :: IPv6 -> ShortText+encodeShort w =+ id $+ TS.fromShortByteStringUnsafe $+ byteArrayToShortByteString $+ BB.run Nat.constant $+ boundedBuilderUtf8 $+ w++byteArrayToShortByteString :: PM.ByteArray -> BSS.ShortByteString+byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x++{- | Decode an 'IPv6' address. This accepts both standard IPv6+notation (with zero compression) and mixed notation for+IPv4-mapped IPv6 addresses. For a decoding function that+additionally accepts dot-decimal-encoded IPv4 addresses,+see @Net.IP.decode@.+-}+decode :: Text -> Maybe IPv6+decode t = rightToMaybe (AT.parseOnly (parser <* AT.endOfInput) t)++{- | Parse UTF-8-encoded 'Bytes' as an 'IPv6' address. This accepts+both uppercase and lowercase characters in the hexadecimal components.++>>> let str = "dead:beef:3240:a426:ba68:1cd0:4263:109b -> alive"+>>> Parser.parseBytes (parserUtf8Bytes ()) (Ascii.fromString str)+Success (Slice {offset = 39, length = 9, value = ipv6 0xdead 0xbeef 0x3240 0xa426 0xba68 0x1cd0 0x4263 0x109b})++This does not currently support parsing embedded IPv4 address+(e.g. @ff00:8000:abc::224.1.2.3@).+-}+parserUtf8Bytes :: e -> Parser.Parser e s IPv6+parserUtf8Bytes e = do+ marr <- Parser.effect (PM.newPrimArray 8)+ -- We cannot immidiately call preZeroes since it wants a+ -- leading colon present.+ Latin.trySatisfy (== ':') >>= \case+ True -> do+ Latin.char e ':'+ postZeroesBegin e marr 0 0+ False -> do+ w <- pieceParser e+ Parser.effect (PM.writePrimArray marr 0 w)+ preZeroes e marr 1++-- This is called when we are positioned before a colon.+-- We may encounter another colon immidiately after+-- the one that we consume here. This indicates zero+-- compression. Or we may encounter another hex-encoded+-- number.+preZeroes ::+ e ->+ MutablePrimArray s Word16 -> -- length must be 8+ Int ->+ Parser.Parser e s IPv6+preZeroes e !marr !ix = case ix of+ 8 -> Parser.effect (combinePieces marr)+ _ -> do+ Latin.char e ':'+ Latin.trySatisfy (== ':') >>= \case+ True -> postZeroesBegin e marr ix ix+ False -> do+ w <- pieceParser e+ Parser.effect (PM.writePrimArray marr ix w)+ preZeroes e marr (ix + 1)++-- The same as postZeroes except that there is no+-- leading that gets consumed. This is called right+-- after a double colon is consumed.+-- Precondition: the index is less than 8. This parser+-- is only called by preZeroes, which ensures that+-- this holds.+postZeroesBegin ::+ e ->+ MutablePrimArray s Word16 -> -- length must be 8+ Int -> -- current index in array+ Int -> -- index where compression happened+ Parser.Parser e s IPv6+postZeroesBegin e !marr !ix !compress = do+ optionalPieceParser e >>= \case+ Nothing -> do+ -- the end has come+ Parser.effect (conclude marr ix compress)+ Just w -> do+ Parser.effect (PM.writePrimArray marr ix w)+ postZeroes e marr (ix + 1) compress++-- Should be run right before a colon.+postZeroes ::+ e ->+ MutablePrimArray s Word16 -> -- length must be 8+ Int -> -- current index in array+ Int -> -- index where compression happened+ Parser.Parser e s IPv6+postZeroes e !marr !ix !compress = case ix of+ 8 -> Parser.fail e+ _ -> do+ Latin.trySatisfy (== ':') >>= \case+ False ->+ -- The end has come+ Parser.effect (conclude marr ix compress)+ True -> do+ w <- pieceParser e+ Parser.effect (PM.writePrimArray marr ix w)+ postZeroes e marr (ix + 1) compress++conclude :: MutablePrimArray s Word16 -> Int -> Int -> ST s IPv6+conclude !marr !ix !compress = do+ -- This will overlap, but GHC's copy primop is fine with that.+ let postCompressionLen = ix - compress+ PM.copyMutablePrimArray marr (8 - postCompressionLen) marr compress postCompressionLen+ let compressedArea = 8 - ix+ PM.setPrimArray marr compress compressedArea (0 :: Word16)+ combinePieces marr++-- Example memmove that may need to happen:+-- A B C H ==> A B C 0 0 0 0 H+-- *+-- ix = 4, compress = 3, postCompressionLen = 1, compressedArea = 4+-- copyPrimArray marr 7 marr 3 1+-- setPrimArray marr 3 4 (0 :: Word16)++combinePieces ::+ MutablePrimArray s Word16 ->+ ST s IPv6+combinePieces !marr =+ fromWord16s+ <$> PM.readPrimArray marr 0+ <*> PM.readPrimArray marr 1+ <*> PM.readPrimArray marr 2+ <*> PM.readPrimArray marr 3+ <*> PM.readPrimArray marr 4+ <*> PM.readPrimArray marr 5+ <*> PM.readPrimArray marr 6+ <*> PM.readPrimArray marr 7++optionalPieceParser :: e -> Parser.Parser e s (Maybe Word16)+optionalPieceParser e =+ Latin.tryHexNibble >>= \case+ Nothing -> pure Nothing+ Just w0 -> do+ r <- pieceParserStep e w0+ pure (Just r)++-- This should probably be moved into bytesmith and renamed.+pieceParser :: e -> Parser.Parser e s Word16+pieceParser e = Latin.hexNibble e >>= pieceParserStep e++-- Parses the remainder of a lowercase hexadecimal number.+-- Leaves trailing colons alone. This fails if there are+-- more than four hex digits unless there are leading zeroes.+-- I cannot find a spec that is clear about what to do+-- if someone puts 00000 in a piece of an encoded IPv6+-- address, so I veer on the side of leniency.+pieceParserStep ::+ e ->+ Word ->+ Parser.Parser e s Word16+pieceParserStep e !acc =+ if acc > 0xFFFF+ then Parser.fail e+ else+ Latin.tryHexNibble >>= \case+ Nothing -> pure (fromIntegral acc)+ Just w -> pieceParserStep e (16 * acc + w)++{- | Parse UTF-8-encoded 'Bytes' into an 'IPv4Range'.+This requires the mask to be present.++>>> maybe (putStrLn "nope") IPv6.printRange $ Parser.parseBytesMaybe (IPv6.parserRangeUtf8Bytes ()) (Ascii.fromString "1b02:f001:5:200b::/80")+1b02:f001:5:200b::/80+>>> maybe (putStrLn "nope") IPv6.printRange $ Parser.parseBytesMaybe (IPv6.parserRangeUtf8Bytes ()) (Ascii.fromString "abcd::")+nope++See 'parserRangeUtf8BytesLenient' for a variant that treats+a missing mask as a @/32@ mask.+-}+parserRangeUtf8Bytes :: e -> Parser.Parser e s IPv6Range+parserRangeUtf8Bytes e = do+ base <- parserUtf8Bytes e+ Latin.char e '/'+ theMask <- Latin.decWord8 e+ if theMask > 128+ then Parser.fail e+ else pure $! normalize (IPv6Range base theMask)++{- | Variant of 'parserRangeUtf8Bytes' that allows the mask+to be omitted. An omitted mask is treated as a @/128@ mask.++>>> maybe (putStrLn "nope") IPv6.printRange $ Parser.parseBytesMaybe (IPv6.parserRangeUtf8BytesLenient ()) (Ascii.fromString "1b02:f001:5:200b::/80")+1b02:f001:5:200b::/80+>>> maybe (putStrLn "nope") IPv6.printRange $ Parser.parseBytesMaybe (IPv6.parserRangeUtf8BytesLenient ()) (Ascii.fromString "abcd::")+abcd::/128+-}+parserRangeUtf8BytesLenient :: e -> Parser.Parser e s IPv6Range+parserRangeUtf8BytesLenient e = do+ base <- parserUtf8Bytes e+ Latin.trySatisfy (== '/') >>= \case+ True -> do+ theMask <- Latin.decWord8 e+ if theMask > 128+ then Parser.fail e+ else pure $! normalize (IPv6Range base theMask)+ False -> pure $! IPv6Range base 128++{- | Parse an 'IPv6' using 'Atto.Parser'.++ >>> Atto.parseOnly IPv6.parser (Text.pack "dead:beef:3240:a426:ba68:1cd0:4263:109b")+ Right (ipv6 0xdead 0xbeef 0x3240 0xa426 0xba68 0x1cd0 0x4263 0x109b)+-}+parser :: Atto.Parser IPv6+parser = makeIP <$> ip+ where+ 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."++ ip = (Atto.char ':' *> Atto.char ':' *> doubleColon 0) <|> part 0++ 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)+ )+ )++ 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)++ -- 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)]++{- | An 'IPv6Range'. It is made up of the first 'IPv6' in the range+ and its length.+-}+data IPv6Range = IPv6Range+ { ipv6RangeBase :: {-# UNPACK #-} !IPv6+ , ipv6RangeLength :: {-# UNPACK #-} !Word8+ }+ deriving (Eq, Ord, Show, Read, Generic, Data)++instance NFData IPv6Range++instance Aeson.ToJSON IPv6Range where+ toJSON = Aeson.String . encodeRange++instance Aeson.FromJSON IPv6Range where+ parseJSON (Aeson.String t) = case decodeRange t of+ Nothing -> fail "Could not decodeRange IPv6 range"+ Just res -> return res+ parseJSON _ = mzero++mask128 :: IPv6+mask128 = maxBound++mask :: Word8 -> IPv6+mask = complement . shiftR mask128 . fromIntegral++{- | Normalize an 'IPv6Range'. The first result of this is that the+ 'IPv6' inside the 'IPv6Range' is changed so that the insignificant+ bits are zeroed out. For example:++ >>> addr1 = IPv6.ipv6 0x0192 0x0168 0x0001 0x0019 0x0000 0x0000 0x0000 0x0000+ >>> addr2 = IPv6.ipv6 0x0192 0x0168 0x0001 0x0163 0x0000 0x0000 0x0000 0x0000+ >>> IPv6.printRange $ IPv6.normalize $ IPv6.IPv6Range addr1 24+ 192:100::/24+ >>> IPv6.printRange $ IPv6.normalize $ IPv6.IPv6Range addr2 28+ 192:160::/28++ The second effect of this is that the mask length is lowered to be 128+ or smaller. Working with 'IPv6Range'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 128).++ Note that 'normalize is idempotent, that is:++ prop> IPv6.normalize r == (IPv6.normalize . IPv6.normalize) r+-}+normalize :: IPv6Range -> IPv6Range+normalize (IPv6Range ip len) =+ let len' = min len 128+ ip' = ip .&. mask len'+ in IPv6Range ip' len'++{- | Encode an 'IPv6Range' as 'Text'.++ >>> addr = IPv6.ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B+ >>> T.putStrLn $ IPv6.encodeRange $ IPv6.IPv6Range addr 28+ dead:beef:3240:a426:ba68:1cd0:4263:109b/28+-}+encodeRange :: IPv6Range -> Text+encodeRange x = encode (ipv6RangeBase x) <> Text.pack "/" <> (Text.pack $ (show . fromEnum) $ ipv6RangeLength x)++{- | Decode an 'IPv6Range' from 'Text'.++ >>> addr = IPv6.ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B+ >>> fmap IPv6.encodeRange $ IPv6.decodeRange (Text.pack "dead:beef:3240:a426:ba68:1cd0:4263:109b/28")+ Just "dead:bee0::/28"+-}+decodeRange :: Text -> Maybe IPv6Range+decodeRange = rightToMaybe . AT.parseOnly (parserRange <* AT.endOfInput)++-- | Parse an 'IPv6Range' using a 'AT.Parser'.+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.ipv6 0x2001 0x0db8 0x0db8 0x1094 0x2051 0x0000 0x0000 0x0001+>>> let iprange mask = IPv6.IPv6Range (IPv6.ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) mask+>>> IPv6.contains (iprange 8) ip+True+>>> IPv6.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 = IPv6.IPv6Range (IPv6.ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) 64+>>> fmap (IPv6.contains r) (take 5 $ iterate succ $ IPv6.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 subnet len) =+ let theMask = mask len+ subnetNormalized = subnet .&. theMask+ in \ip -> (ip .&. theMask) == subnetNormalized++-- | Checks if the first range is a subset of the second range.+isSubsetOf :: IPv6Range -> IPv6Range -> Bool+isSubsetOf a b =+ lowerInclusive a >= lowerInclusive b+ && upperInclusive a <= upperInclusive b++{- | This is provided to mirror the interface provided by @Data.Set@. It+behaves just like 'contains' but with flipped arguments.++prop> IPv6.member ip r == IPv6.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 $ IPv6.encode $ IPv6.lowerInclusive $ IPv6.IPv6Range (IPv6.ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001) 25+2001:d80::++Note that the lower bound of a normalized 'IPv6Range' is simply the+ip address of the range:++prop> IPv6.lowerInclusive r == IPv6.ipv6RangeBase (IPv6.normalize r)+-}+lowerInclusive :: IPv6Range -> IPv6+lowerInclusive = ipv6RangeBase . normalize++{- | The inclusive upper bound of an 'IPv6Range'.++ >>> let addr = IPv6.ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B+ >>> T.putStrLn $ IPv6.encode $ IPv6.upperInclusive $ IPv6.IPv6Range addr 25+ dead:beff:ffff:ffff:ffff:ffff:ffff:ffff+-}+upperInclusive :: IPv6Range -> IPv6+upperInclusive (IPv6Range ip len) =+ let len' = min 128 len+ theInvertedMask :: IPv6+ theInvertedMask = shiftR mask128 (fromIntegral len')+ in ip .|. theInvertedMask++-- | Print an 'IPv6Range' using the textual encoding.+printRange :: IPv6Range -> IO ()+printRange = TIO.putStrLn . encodeRange++{- | Smart constructor for 'IPv6Range'. Ensures the mask is appropriately+ sized and sets masked bits in the 'IPv6' to zero.++ >>> let addr = IPv6.ipv6 0xDEAD 0xBEEF 0x3240 0xA426 0xBA68 0x1CD0 0x4263 0x109B+ >>> IPv6.printRange $ IPv6.range addr 25+ dead:be80::/25+-}+range :: IPv6 -> Word8 -> IPv6Range+range addr len = normalize (IPv6Range addr len)++{- | Given an inclusive lower and upper ip address, create the smallest 'IPv6Range'+ that contains the two. This is helpful in situations where input is given as a+ range, like @ @.++ This makes the range broader if it cannot be represented in <https://en.wikipedia.org/wiki/Classless_Inter-Domain_Routing CIDR> notation.++ >>> addrLower = IPv6.ipv6 0xDEAD 0xBE80 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000+ >>> addrUpper = IPv6.ipv6 0xDEAD 0xBEFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF 0xFFFF+ >>> IPv6.printRange $ IPv6.fromBounds addrLower addrUpper+ dead:be80::/25+-} fromBounds :: IPv6 -> IPv6 -> IPv6Range fromBounds lo hi = normalize (IPv6Range lo (maskFromBounds lo hi))
src/Net/Mac.hs view
@@ -1,15 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -{-| This module provides the Mac data type and functions for working+{- | This module provides the Mac data type and functions for working with it. -} module Net.Mac@@ -17,7 +21,9 @@ mac , fromOctets , toOctets+ -- * Textual Conversion+ -- ** Text , encode , encodeWith@@ -26,6 +32,10 @@ , builder , parser , parserWith++ -- ** ShortText+ , encodeShort+ -- ** UTF-8 ByteString , encodeUtf8 , encodeWithUtf8@@ -34,41 +44,52 @@ , builderUtf8 , parserUtf8 , parserWithUtf8+ -- ** ByteString , decodeBytes+ , decodeOctets++ -- ** UTF-8 Bytes+ , boundedBuilderUtf8+ , decodeUtf8Bytes+ , parserUtf8Bytes+ -- ** Printing , print++ -- * Default Codec+ , defCodec+ -- * Types- , Mac(..)- , MacCodec(..)- , MacGrouping(..)+ , Mac (..)+ , MacCodec (..)+ , MacGrouping (..) ) where import Prelude hiding (print) import Control.DeepSeq (NFData)-import Data.Aeson (FromJSON(..),ToJSON(..))-import Data.Aeson (ToJSONKey(..),FromJSONKey(..))-import Data.Aeson (ToJSONKeyFunction(..),FromJSONKeyFunction(..))-import Data.Bits ((.|.),unsafeShiftL,unsafeShiftR,(.&.))+import Data.Aeson (FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..))+import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) import Data.ByteString (ByteString)-import Data.Char (ord,chr)+import Data.ByteString.Short.Internal (ShortByteString (SBS))+import Data.Char (chr, ord)+import Data.Data (Data) import Data.Hashable (Hashable)-import Data.Primitive.Types (Prim(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup ((<>))-#endif+import Data.Ix (Ix)+import Data.Primitive.ByteArray (ByteArray (ByteArray))+import Data.Primitive.Types (Prim (..)) import Data.Text (Text)+import Data.Text.Short (ShortText) import Data.Word-import Data.Word (Word8) import Data.Word.Synthetic.Word12 (Word12) import GHC.Enum (predError, succError) import GHC.Exts import GHC.Generics (Generic)-import GHC.Word (Word16(W16#))-import Text.ParserCombinators.ReadPrec (prec,step)-import Text.Read (Read(..),Lexeme(Ident),lexP,parens)+import Text.ParserCombinators.ReadPrec (prec, step)+import Text.Read (Lexeme (Ident), Read (..), lexP, parens) +import qualified Arithmetic.Nat as Nat import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.Attoparsec.ByteString as AB@@ -78,38 +99,76 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Fixed as BFB import qualified Data.ByteString.Unsafe as BU+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Builder.Bounded as BBB+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Text as Text () import qualified Data.Text.Builder.Fixed as TFB import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text as Text ()+import qualified Data.Text.Short.Unsafe as TS+import qualified GHC.Prim.Compat as Compat+import qualified GHC.Word.Compat as Compat --- $setup------ These are here to get doctest's property checking to work------ >>> :set -XOverloadedStrings--- >>> import Test.QuickCheck (Arbitrary(..))--- >>> import qualified Data.Text as Text (pack)--- >>> import qualified Data.Text.IO as T--- >>> import qualified Data.ByteString.Char8 as BC--- >>> instance Arbitrary Mac where { arbitrary = fmap (Mac . (0xFFFFFFFFFFFF .&.)) arbitrary }+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as AK+#endif --- | Construct a 'Mac' address from a 'Word64'. Only the lower--- 48 bits are used.+{- | A 48-bit MAC address. Do not use the data constructor for this+ type. It is not considered part of the stable API, and it+ allows you to construct invalid MAC addresses.+-}+newtype Mac = Mac Word64+ deriving stock (Eq, Ord, Generic, Ix, Data)+ deriving newtype (Hashable)++instance NFData Mac++{- $setup++These are here to get doctest's property checking to work++>>> :set -XOverloadedStrings+>>> import Test.QuickCheck (Arbitrary(..),CoArbitrary(..),coarbitraryEnum)+>>> import qualified Data.Text as Text (pack)+>>> import qualified Data.Text.IO as T+>>> import qualified Data.ByteString.Char8 as BC+>>> import qualified Data.ByteString as B+>>> import qualified Data.Bytes.Text.Ascii as Ascii+>>> import qualified Net.Mac as Mac+>>> import qualified Arithmetic.Nat as Nat+>>> import qualified Data.Attoparsec.Text as AT+>>> import qualified Data.Bytes.Builder.Bounded as BBB+>>> import Net.Mac (Mac(Mac))+>>> instance Arbitrary Mac where { arbitrary = fmap (Mac . (0xFFFFFFFFFFFF .&.)) arbitrary }+>>> instance CoArbitrary Mac where { coarbitrary = coarbitraryEnum }+-}++{- | Construct a 'Mac' address from a 'Word64'. Only the lower+ 48 bits are used.+-} mac :: Word64 -> Mac mac w = Mac (w .&. 0xFFFFFFFFFFFF) -- | Create a 'Mac' address from six octets. fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac-fromOctets a b c d e f = Mac $ unsafeWord48FromOctets- (fromIntegral a) (fromIntegral b) (fromIntegral c)- (fromIntegral d) (fromIntegral e) (fromIntegral f)+fromOctets a b c d e f =+ Mac $+ unsafeWord48FromOctets+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)+ (fromIntegral e)+ (fromIntegral f) --- | Convert a 'Mac' address to the six octets that make it up.--- This function and 'fromOctets' are inverses:------ prop> m == (let (a,b,c,d,e,f) = toOctets m in fromOctets a b c d e f)-toOctets :: Mac -> (Word8,Word8,Word8,Word8,Word8,Word8)+{- | Convert a 'Mac' address to the six octets that make it up.+ This function and 'fromOctets' are inverses:++ prop> m == (let (a,b,c,d,e,f) = Mac.toOctets m in Mac.fromOctets a b c d e f)+-}+toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8) toOctets (Mac w) = ( fromIntegral $ unsafeShiftR w 40 , fromIntegral $ unsafeShiftR w 32@@ -119,49 +178,64 @@ , fromIntegral w ) --- | Decode a 'Mac' address from a 'ByteString'. Each byte is interpreted--- as an octet of the 'Mac' address. Consequently, 'ByteString's--- of length 6 successfully decode, and all other 'ByteString's fail--- to decode.------ >>> decodeBytes (B.pack [0x6B,0x47,0x18,0x90,0x55,0xC3])--- Just (mac 0x6b47189055c3)--- >>> decodeBytes (B.replicate 6 0x3A)--- Just (mac 0x3a3a3a3a3a3a)--- >>> decodeBytes (B.replicate 7 0x3A)--- Nothing+{- | This function is deprecated. It will be renamed in a future release+ since the name is misleading.+-} decodeBytes :: ByteString -> Maybe Mac-decodeBytes bs = if B.length bs == 6- then Just $ fromOctets- (BU.unsafeIndex bs 0)- (BU.unsafeIndex bs 1)- (BU.unsafeIndex bs 2)- (BU.unsafeIndex bs 3)- (BU.unsafeIndex bs 4)- (BU.unsafeIndex bs 5)- else Nothing+{-# DEPRECATED decodeBytes "Prefer decodeOctets" #-}+decodeBytes = decodeOctets +{- | Decode a 'Mac' address from a 'ByteString'. Each byte is interpreted+ as an octet of the 'Mac' address. Consequently, 'ByteString's+ of length 6 successfully decode, and all other 'ByteString's fail+ to decode.++ >>> Mac.decodeOctets (B.pack [0x6B,0x47,0x18,0x90,0x55,0xC3])+ Just (mac 0x6b47189055c3)+ >>> Mac.decodeOctets (B.replicate 6 0x3A)+ Just (mac 0x3a3a3a3a3a3a)+ >>> Mac.decodeOctets (B.replicate 7 0x3A)+ Nothing++ Note that the octets are interpreted in a big-endian fashion.+-}+decodeOctets :: ByteString -> Maybe Mac+decodeOctets bs =+ if B.length bs == 6+ then+ Just $+ fromOctets+ (BU.unsafeIndex bs 0)+ (BU.unsafeIndex bs 1)+ (BU.unsafeIndex bs 2)+ (BU.unsafeIndex bs 3)+ (BU.unsafeIndex bs 4)+ (BU.unsafeIndex bs 5)+ else Nothing+ rightToMaybe :: Either a b -> Maybe b rightToMaybe = either (const Nothing) Just c2w :: Char -> Word8 c2w = fromIntegral . ord --- | Encode a 'Mac' address using the default 'MacCodec' 'defCodec'.------ >>> T.putStrLn (encode (Mac 0xA47F247AB423))--- a4:7f:24:7a:b4:23+{- | Encode a 'Mac' address using the default 'MacCodec' 'defCodec'.++ >>> T.putStrLn (Mac.encode (Mac 0xA47F247AB423))+ a4:7f:24:7a:b4:23+-} encode :: Mac -> Text encode = encodeWith defCodec --- | Encode a 'Mac' address using the given 'MacCodec'.------ >>> m = Mac 0xA47F247AB423--- >>> T.putStrLn $ encodeWith defCodec m--- a4:7f:24:7a:b4:23------ >>> T.putStrLn $ encodeWith (MacCodec (MacGroupingTriples '-') True) m--- A47-F24-7AB-423+{- | Encode a 'Mac' address using the given 'MacCodec'.++ >>> m = Mac 0xA47F247AB423+ >>> T.putStrLn $ Mac.encodeWith Mac.defCodec m+ a4:7f:24:7a:b4:23++ >>> T.putStrLn $ Mac.encodeWith (Mac.MacCodec (Mac.MacGroupingTriples '-') True) m+ A47-F24-7AB-423+-} encodeWith :: MacCodec -> Mac -> Text encodeWith (MacCodec g u) m = case g of MacGroupingNoSeparator -> case u of@@ -170,7 +244,7 @@ MacGroupingPairs c -> case u of True -> TFB.run (fixedBuilderPairs TFB.word8HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderPairs TFB.word8HexFixedLower) (Pair c m)- -- withCasedBuilder u $ \bw8 -> TFB.run (fixedBuilderPairs bw8) (Pair c m)+ -- withCasedBuilder u $ \bw8 -> TFB.run (fixedBuilderPairs bw8) (Pair c m) MacGroupingTriples c -> case u of True -> TFB.run (fixedBuilderTriples TFB.word12HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderTriples TFB.word12HexFixedLower) (Pair c m)@@ -178,23 +252,25 @@ True -> TFB.run (fixedBuilderQuadruples TFB.word8HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderQuadruples TFB.word8HexFixedLower) (Pair c m) --- | Decode a 'Mac' address using the default 'MacCodec' 'defCodec'.------ >>> decode (Text.pack "a4:7f:24:7a:b4:23")--- Just (mac 0xa47f247ab423)------ >>> decode (Text.pack "a47-f24-7ab-423")--- Nothing+{- | Decode a 'Mac' address using the default 'MacCodec' 'defCodec'.++ >>> Mac.decode (Text.pack "a4:7f:24:7a:b4:23")+ Just (mac 0xa47f247ab423)++ >>> Mac.decode (Text.pack "a47-f24-7ab-423")+ Nothing+-} decode :: Text -> Maybe Mac decode = decodeWith defCodec --- | Decode a 'Mac' address from 'Text' using the given 'MacCodec'.------ >>> decodeWith defCodec (Text.pack "a4:7f:24:7a:b4:23")--- Just (mac 0xa47f247ab423)------ >>> decodeWith (MacCodec MacGroupingNoSeparator False) (Text.pack "a47f247ab423")--- Just (mac 0xa47f247ab423)+{- | Decode a 'Mac' address from 'Text' using the given 'MacCodec'.++>>> Mac.decodeWith Mac.defCodec (Text.pack "a4:7f:24:7a:b4:23")+Just (mac 0xa47f247ab423)++>>> Mac.decodeWith (Mac.MacCodec Mac.MacGroupingNoSeparator False) (Text.pack "a47f247ab423")+Just (mac 0xa47f247ab423)+-} decodeWith :: MacCodec -> Text -> Maybe Mac decodeWith codec t = rightToMaybe (AT.parseOnly (parserWith codec <* AT.endOfInput) t) @@ -202,25 +278,27 @@ builder :: Mac -> TBuilder.Builder builder = TBuilder.fromText . encode --- | Parse a 'Mac' address using a 'AT.Parser'.------ >>> AT.parseOnly parser (Text.pack "a4:7f:24:7a:b4:23")--- Right (mac 0xa47f247ab423)------ >>> AT.parseOnly parser (Text.pack "a47-f24-7ab-423")--- Left "':': Failed reading: satisfy"+{- | Parse a 'Mac' address using a 'AT.Parser'.++ >>> AT.parseOnly Mac.parser (Text.pack "a4:7f:24:7a:b4:23")+ Right (mac 0xa47f247ab423)++ >>> AT.parseOnly Mac.parser (Text.pack "a47-f24-7ab-423")+ Left "':': Failed reading: satisfy"+-} parser :: AT.Parser Mac parser = parserWith defCodec --- | Parser a 'Mac' address using the given 'MacCodec'.------ >>> p1 = parserWith defCodec--- >>> AT.parseOnly p1 (Text.pack "a4:7f:24:7a:b4:23")--- Right (mac 0xa47f247ab423)------ >>> p2 = parserWith (MacCodec MacGroupingNoSeparator False)--- >>> AT.parseOnly p2 (Text.pack "a47f247ab423")--- Right (mac 0xa47f247ab423)+{- | Parser a 'Mac' address using the given 'MacCodec'.++ >>> p1 = Mac.parserWith Mac.defCodec+ >>> AT.parseOnly p1 (Text.pack "a4:7f:24:7a:b4:23")+ Right (mac 0xa47f247ab423)++ >>> p2 = Mac.parserWith (Mac.MacCodec Mac.MacGroupingNoSeparator False)+ >>> AT.parseOnly p2 (Text.pack "a47f247ab423")+ Right (mac 0xa47f247ab423)+-} parserWith :: MacCodec -> AT.Parser Mac parserWith (MacCodec g _) = case g of MacGroupingQuadruples c -> parserQuadruples c@@ -228,27 +306,40 @@ MacGroupingPairs c -> parserPairs c MacGroupingNoSeparator -> parserNoSeparator --- | The default 'MacCodec': all characters are lowercase hex, separated by colons into pairs.------ >>> T.putStrLn $ encodeWith defCodec (Mac 0xa47f247ab423)--- a4:7f:24:7a:b4:23+{- | The default 'MacCodec': all characters are lowercase hex, separated by colons into pairs.++ >>> T.putStrLn $ Mac.encodeWith Mac.defCodec (Mac 0xa47f247ab423)+ a4:7f:24:7a:b4:23+-} defCodec :: MacCodec defCodec = MacCodec (MacGroupingPairs ':') False parserQuadruples :: Char -> AT.Parser Mac-parserQuadruples s = fromOctets- <$> parseTwoHex <*> parseTwoHex <* AT.char s- <*> parseTwoHex <*> parseTwoHex <* AT.char s- <*> parseTwoHex <*> parseTwoHex+parserQuadruples s =+ fromOctets+ <$> parseTwoHex+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <*> parseTwoHex parserPairs :: Char -> AT.Parser Mac-parserPairs s = fromOctets- <$> parseTwoHex <* AT.char s- <*> parseTwoHex <* AT.char s- <*> parseTwoHex <* AT.char s- <*> parseTwoHex <* AT.char s- <*> parseTwoHex <* AT.char s- <*> parseTwoHex+parserPairs s =+ fromOctets+ <$> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex+ <* AT.char s+ <*> parseTwoHex parserTriples :: Char -> AT.Parser Mac parserTriples s = do@@ -267,22 +358,24 @@ a10 <- parseOneHex a11 <- parseOneHex a12 <- parseOneHex- return $ fromOctets- (unsafeShiftL a1 4 + a2)- (unsafeShiftL a3 4 + a4)- (unsafeShiftL a5 4 + a6)- (unsafeShiftL a7 4 + a8)- (unsafeShiftL a9 4 + a10)- (unsafeShiftL a11 4 + a12)+ return $+ fromOctets+ (unsafeShiftL a1 4 + a2)+ (unsafeShiftL a3 4 + a4)+ (unsafeShiftL a5 4 + a6)+ (unsafeShiftL a7 4 + a8)+ (unsafeShiftL a9 4 + a10)+ (unsafeShiftL a11 4 + a12) parserNoSeparator :: AT.Parser Mac-parserNoSeparator = fromOctets- <$> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex+parserNoSeparator =+ fromOctets+ <$> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex parseTwoHex :: AT.Parser Word8 parseTwoHex = do@@ -296,7 +389,8 @@ | w >= 65 && w <= 70 = return (w - 55) | w >= 97 && w <= 102 = return (w - 87) | otherwise = a- where w = c2w c+ where+ w = c2w c parseOneHex :: AT.Parser Word8 parseOneHex = AT.anyChar >>= parseCharHex@@ -311,50 +405,50 @@ fixedBuilderTriples :: TFB.Builder Word12 -> TFB.Builder Pair fixedBuilderTriples tripBuilder =- TFB.contramapBuilder (word12At 36 . pairMac) tripBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word12At 24 . pairMac) tripBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word12At 12 . pairMac) tripBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word12At 0 . pairMac) tripBuilder+ TFB.contramapBuilder (word12At 36 . pairMac) tripBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word12At 24 . pairMac) tripBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word12At 12 . pairMac) tripBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word12At 0 . pairMac) tripBuilder {-# INLINE fixedBuilderTriples #-} fixedBuilderNoSeparator :: TFB.Builder Word8 -> TFB.Builder Mac fixedBuilderNoSeparator hexBuilder =- TFB.contramapBuilder (word8At 40) hexBuilder- <> TFB.contramapBuilder (word8At 32) hexBuilder- <> TFB.contramapBuilder (word8At 24) hexBuilder- <> TFB.contramapBuilder (word8At 16) hexBuilder- <> TFB.contramapBuilder (word8At 8) hexBuilder- <> TFB.contramapBuilder (word8At 0) hexBuilder+ TFB.contramapBuilder (word8At 40) hexBuilder+ <> TFB.contramapBuilder (word8At 32) hexBuilder+ <> TFB.contramapBuilder (word8At 24) hexBuilder+ <> TFB.contramapBuilder (word8At 16) hexBuilder+ <> TFB.contramapBuilder (word8At 8) hexBuilder+ <> TFB.contramapBuilder (word8At 0) hexBuilder {-# INLINE fixedBuilderNoSeparator #-} fixedBuilderQuadruples :: TFB.Builder Word8 -> TFB.Builder Pair fixedBuilderQuadruples pairBuilder =- TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder+ TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder+ <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder+ <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder+ <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder {-# INLINE fixedBuilderQuadruples #-} fixedBuilderPairs :: TFB.Builder Word8 -> TFB.Builder Pair fixedBuilderPairs pairBuilder =- TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> TFB.contramapBuilder pairSep TFB.charBmp- <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder+ TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder+ <> TFB.contramapBuilder pairSep TFB.charBmp+ <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder {-# INLINE fixedBuilderPairs #-} word8At :: Int -> Mac -> Word8@@ -365,46 +459,119 @@ word12At i (Mac w) = fromIntegral (unsafeShiftR w i) {-# INLINE word12At #-} --- | Encode a 'Mac' address using the default 'MacCodec' 'defCodec'.------ >>> BC.putStrLn (encodeUtf8 (mac 0x64255A0F2C47))--- 64:25:5a:0f:2c:47+{- | Encode a 'Mac' address using the default 'MacCodec' 'defCodec'.++ >>> BC.putStrLn (Mac.encodeUtf8 (Mac.mac 0x64255A0F2C47))+ 64:25:5a:0f:2c:47+-} encodeUtf8 :: Mac -> ByteString encodeUtf8 = encodeWithUtf8 defCodec --- | Lenient decoding of MAC address that accepts lowercase, uppercase,--- and any kind of separator.------ >>> decodeUtf8 "A2:DE:AD:BE:EF:67"--- Just (mac 0xa2deadbeef67)--- >>> decodeUtf8 "13-a2-fe-a4-17-96"--- Just (mac 0x13a2fea41796)--- >>> decodeUtf8 "0A42.47BA.67C2"--- Just (mac 0x0a4247ba67c2)+{- | Lenient decoding of MAC address that accepts lowercase, uppercase,+ and any kind of separator.++ >>> Mac.decodeUtf8 "A2:DE:AD:BE:EF:67"+ Just (mac 0xa2deadbeef67)+ >>> Mac.decodeUtf8 "13-a2-fe-a4-17-96"+ Just (mac 0x13a2fea41796)+ >>> Mac.decodeUtf8 "0A42.47BA.67C2"+ Just (mac 0x0a4247ba67c2)+-} decodeUtf8 :: ByteString -> Maybe Mac decodeUtf8 = decodeLenientUtf8 --- | Decode a 'ByteString' as a 'Mac' address using the given 'MacCodec'.------ >>> decodeWithUtf8 defCodec (BC.pack "64:25:5a:0f:2c:47")--- Just (mac 0x64255a0f2c47)------ >>> decodeWithUtf8 (MacCodec MacGroupingNoSeparator False) (BC.pack "64255a0f2c47")--- Just (mac 0x64255a0f2c47)+{- | Decode a 'ByteString' as a 'Mac' address using the given 'MacCodec'.++ >>> Mac.decodeWithUtf8 Mac.defCodec (BC.pack "64:25:5a:0f:2c:47")+ Just (mac 0x64255a0f2c47)++ >>> Mac.decodeWithUtf8 (Mac.MacCodec Mac.MacGroupingNoSeparator False) (BC.pack "64255a0f2c47")+ Just (mac 0x64255a0f2c47)+-} decodeWithUtf8 :: MacCodec -> ByteString -> Maybe Mac decodeWithUtf8 codec bs = rightToMaybe (AB.parseOnly (parserWithUtf8 codec <* AB.endOfInput) bs) decodeLenientUtf8 :: ByteString -> Maybe Mac decodeLenientUtf8 bs = rightToMaybe (AB.parseOnly (parserLenientUtf8 <* AB.endOfInput) bs) --- | Make a bytestring builder from a 'Mac' address--- using a colon as the separator.+{- | Encode a 'Mac' address as colon-separated hexadecimal octets,+ preferring lowercase for alphabetical characters.+-}+encodeShort :: Mac -> ShortText+encodeShort !m = case BBB.run Nat.constant (boundedBuilderUtf8 m) of+ ByteArray x -> TS.fromShortByteStringUnsafe (SBS x)++{- | Encode a 'Mac' address as colon-separated hexadecimal octets,+ preferring lowercase for alphabetical characters.++ >>> BBB.run Nat.constant $ Mac.boundedBuilderUtf8 $ Mac.mac 0xDEADBEEF1609+ [0x64, 0x65, 0x3a, 0x61, 0x64, 0x3a, 0x62, 0x65, 0x3a, 0x65, 0x66, 0x3a, 0x31, 0x36, 0x3a, 0x30, 0x39]+-}+boundedBuilderUtf8 :: Mac -> BBB.Builder 17+boundedBuilderUtf8 !w =+ BBB.word8PaddedLowerHex w0+ `BBB.append` BBB.ascii ':'+ `BBB.append` BBB.word8PaddedLowerHex w1+ `BBB.append` BBB.ascii ':'+ `BBB.append` BBB.word8PaddedLowerHex w2+ `BBB.append` BBB.ascii ':'+ `BBB.append` BBB.word8PaddedLowerHex w3+ `BBB.append` BBB.ascii ':'+ `BBB.append` BBB.word8PaddedLowerHex w4+ `BBB.append` BBB.ascii ':'+ `BBB.append` BBB.word8PaddedLowerHex w5+ where+ (w0, w1, w2, w3, w4, w5) = toOctets w++{- | Lenient decoding of MAC address. This+ is case insensitive and allows either @:@ or @-@ as the separator.+ It also allows leading zeroes to be missing.++ >>> Mac.decodeUtf8Bytes (Ascii.fromString "A2:DE:AD:BE:EF:67")+ Just (mac 0xa2deadbeef67)+ >>> Mac.decodeUtf8Bytes (Ascii.fromString "13-a2-FE-A4-17-96")+ Just (mac 0x13a2fea41796)+-}+decodeUtf8Bytes :: Bytes.Bytes -> Maybe Mac+decodeUtf8Bytes = Parser.parseBytesMaybe (parserUtf8Bytes ())++{- | Leniently parse UTF-8-encoded 'Bytes' as a 'Mac' address. This+ is case insensitive and allows either @:@ or @-@ as the separator.+ It also allows leading zeroes to be missing.++ >>> Parser.parseBytes (Mac.parserUtf8Bytes ()) (Ascii.fromString "de:ad:BE:EF:1:23")+ Success (Slice {offset = 16, length = 0, value = mac 0xdeadbeef0123})+-}+parserUtf8Bytes :: e -> Parser.Parser e s Mac+parserUtf8Bytes e = do+ w1 <- Latin.hexWord8 e+ Latin.any e >>= \case+ ':' -> do+ w2 <- Latin.hexWord8 e <* Latin.char e ':'+ w3 <- Latin.hexWord8 e <* Latin.char e ':'+ w4 <- Latin.hexWord8 e <* Latin.char e ':'+ w5 <- Latin.hexWord8 e <* Latin.char e ':'+ w6 <- Latin.hexWord8 e+ pure (fromOctets w1 w2 w3 w4 w5 w6)+ '-' -> do+ w2 <- Latin.hexWord8 e <* Latin.char e '-'+ w3 <- Latin.hexWord8 e <* Latin.char e '-'+ w4 <- Latin.hexWord8 e <* Latin.char e '-'+ w5 <- Latin.hexWord8 e <* Latin.char e '-'+ w6 <- Latin.hexWord8 e+ pure (fromOctets w1 w2 w3 w4 w5 w6)+ _ -> Parser.fail e++{- | Make a bytestring builder from a 'Mac' address+ using a colon as the separator.+-} builderUtf8 :: Mac -> BB.Builder builderUtf8 = BB.byteString . encodeUtf8 --- | Lenient parser for a 'Mac' address using any character--- as the separator and accepting any digit grouping--- (i.e. @FA:43:B2:C0:0F:99@ or @A065.647B.87FA@).+{- | Lenient parser for a 'Mac' address using any character+ as the separator and accepting any digit grouping+ (i.e. @FA:43:B2:C0:0F:99@ or @A065.647B.87FA@).+-} parserUtf8 :: AB.Parser Mac parserUtf8 = parserLenientUtf8 @@ -430,32 +597,39 @@ a10 <- parseOneHexLenientUtf8 a11 <- parseOneHexLenientUtf8 a12 <- parseOneHexLenientUtf8- return $ fromOctets- (unsafeShiftL a1 4 + a2)- (unsafeShiftL a3 4 + a4)- (unsafeShiftL a5 4 + a6)- (unsafeShiftL a7 4 + a8)- (unsafeShiftL a9 4 + a10)- (unsafeShiftL a11 4 + a12)-+ return $+ fromOctets+ (unsafeShiftL a1 4 + a2)+ (unsafeShiftL a3 4 + a4)+ (unsafeShiftL a5 4 + a6)+ (unsafeShiftL a7 4 + a8)+ (unsafeShiftL a9 4 + a10)+ (unsafeShiftL a11 4 + a12) parserNoSeparatorUtf8 :: AB.Parser Mac-parserNoSeparatorUtf8 = fromOctets- <$> parseTwoHexUtf8- <*> parseTwoHexUtf8- <*> parseTwoHexUtf8- <*> parseTwoHexUtf8- <*> parseTwoHexUtf8- <*> parseTwoHexUtf8+parserNoSeparatorUtf8 =+ fromOctets+ <$> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8 parserPairsUtf8 :: Word8 -> AB.Parser Mac-parserPairsUtf8 s = fromOctets- <$> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8+parserPairsUtf8 s =+ fromOctets+ <$> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8 parserTriplesUtf8 :: Word8 -> AB.Parser Mac parserTriplesUtf8 s = do@@ -474,25 +648,33 @@ a10 <- parseOneHexUtf8 a11 <- parseOneHexUtf8 a12 <- parseOneHexUtf8- return $ fromOctets- (unsafeShiftL a1 4 + a2)- (unsafeShiftL a3 4 + a4)- (unsafeShiftL a5 4 + a6)- (unsafeShiftL a7 4 + a8)- (unsafeShiftL a9 4 + a10)- (unsafeShiftL a11 4 + a12)+ return $+ fromOctets+ (unsafeShiftL a1 4 + a2)+ (unsafeShiftL a3 4 + a4)+ (unsafeShiftL a5 4 + a6)+ (unsafeShiftL a7 4 + a8)+ (unsafeShiftL a9 4 + a10)+ (unsafeShiftL a11 4 + a12) parserQuadruplesUtf8 :: Word8 -> AB.Parser Mac-parserQuadruplesUtf8 s = fromOctets- <$> parseTwoHexUtf8 <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <*> parseTwoHexUtf8 <* ABW.word8 s- <*> parseTwoHexUtf8 <*> parseTwoHexUtf8+parserQuadruplesUtf8 s =+ fromOctets+ <$> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8+ <* ABW.word8 s+ <*> parseTwoHexUtf8+ <*> parseTwoHexUtf8 parseOneHexUtf8 :: AB.Parser Word8 parseOneHexUtf8 = ABW.anyWord8 >>= parseWord8Hex --- | Parse a single hexidecimal character. This will skip--- at most one character to do this.+{- | Parse a single hexidecimal character. This will skip+ at most one character to do this.+-} parseOneHexLenientUtf8 :: AB.Parser Word8 parseOneHexLenientUtf8 = do a <- ABW.anyWord8@@ -506,9 +688,10 @@ b <- ABW.anyWord8 >>= parseWord8Hex return (unsafeShiftL a 4 + b) --- | Kind of a confusing type signature. The Word8 that stands--- alone represented an ascii-encoded value. The others actually--- describes the numbers that would be decoded from this value.+{- | Kind of a confusing type signature. The Word8 that stands+ alone represented an ascii-encoded value. The others actually+ describes the numbers that would be decoded from this value.+-} tryParseWord8Hex :: AB.Parser Word8 -> Word8 -> AB.Parser Word8 tryParseWord8Hex a w | w >= 48 && w <= 57 = return (w - 48)@@ -519,14 +702,15 @@ parseWord8Hex :: Word8 -> AB.Parser Word8 parseWord8Hex = tryParseWord8Hex (fail "invalid hexadecimal character") --- | Encode a 'Mac' address as a 'ByteString' using the given 'MacCodec'.------ >>> m = Mac 0xA47F247AB423--- >>> BC.putStrLn $ encodeWithUtf8 defCodec m--- a4:7f:24:7a:b4:23------ >>> BC.putStrLn $ encodeWithUtf8 (MacCodec (MacGroupingTriples '-') True) m--- A47-F24-7AB-423+{- | Encode a 'Mac' address as a 'ByteString' using the given 'MacCodec'.++ >>> m = Mac 0xA47F247AB423+ >>> BC.putStrLn $ Mac.encodeWithUtf8 Mac.defCodec m+ a4:7f:24:7a:b4:23++ >>> BC.putStrLn $ Mac.encodeWithUtf8 (Mac.MacCodec (Mac.MacGroupingTriples '-') True) m+ A47-F24-7AB-423+-} encodeWithUtf8 :: MacCodec -> Mac -> ByteString encodeWithUtf8 (MacCodec g u) m = case g of MacGroupingNoSeparator -> case u of@@ -535,7 +719,7 @@ MacGroupingPairs c -> case u of True -> BFB.run (fixedBuilderPairsUtf8 BFB.word8HexFixedUpper) (PairUtf8 (c2w c) m) False -> BFB.run (fixedBuilderPairsUtf8 BFB.word8HexFixedLower) (PairUtf8 (c2w c) m)- -- withCasedBuilder u $ \bw8 -> BFB.run (fixedBuilderPairs bw8) (Pair c m)+ -- withCasedBuilder u $ \bw8 -> BFB.run (fixedBuilderPairs bw8) (Pair c m) MacGroupingTriples c -> case u of True -> BFB.run (fixedBuilderTriplesUtf8 BFB.word12HexFixedUpper) (PairUtf8 (c2w c) m) False -> BFB.run (fixedBuilderTriplesUtf8 BFB.word12HexFixedLower) (PairUtf8 (c2w c) m)@@ -550,50 +734,50 @@ fixedBuilderTriplesUtf8 :: BFB.Builder Word12 -> BFB.Builder PairUtf8 fixedBuilderTriplesUtf8 tripBuilder =- BFB.contramapBuilder (word12AtUtf8 36 . pairMacUtf8) tripBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word12AtUtf8 24 . pairMacUtf8) tripBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word12AtUtf8 12 . pairMacUtf8) tripBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word12AtUtf8 0 . pairMacUtf8) tripBuilder+ BFB.contramapBuilder (word12AtUtf8 36 . pairMacUtf8) tripBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word12AtUtf8 24 . pairMacUtf8) tripBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word12AtUtf8 12 . pairMacUtf8) tripBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word12AtUtf8 0 . pairMacUtf8) tripBuilder {-# INLINE fixedBuilderTriplesUtf8 #-} fixedBuilderQuadruplesUtf8 :: BFB.Builder Word8 -> BFB.Builder PairUtf8 fixedBuilderQuadruplesUtf8 pairBuilder =- BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder+ BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder {-# INLINE fixedBuilderQuadruplesUtf8 #-} fixedBuilderPairsUtf8 :: BFB.Builder Word8 -> BFB.Builder PairUtf8 fixedBuilderPairsUtf8 pairBuilder =- BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder- <> BFB.contramapBuilder pairSepUtf8 BFB.word8- <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder+ BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder+ <> BFB.contramapBuilder pairSepUtf8 BFB.word8+ <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder {-# INLINE fixedBuilderPairsUtf8 #-} fixedBuilderNoSeparatorUtf8 :: BFB.Builder Word8 -> BFB.Builder Mac fixedBuilderNoSeparatorUtf8 hexBuilder =- BFB.contramapBuilder (word8AtUtf8 40) hexBuilder- <> BFB.contramapBuilder (word8AtUtf8 32) hexBuilder- <> BFB.contramapBuilder (word8AtUtf8 24) hexBuilder- <> BFB.contramapBuilder (word8AtUtf8 16) hexBuilder- <> BFB.contramapBuilder (word8AtUtf8 8) hexBuilder- <> BFB.contramapBuilder (word8AtUtf8 0) hexBuilder+ BFB.contramapBuilder (word8AtUtf8 40) hexBuilder+ <> BFB.contramapBuilder (word8AtUtf8 32) hexBuilder+ <> BFB.contramapBuilder (word8AtUtf8 24) hexBuilder+ <> BFB.contramapBuilder (word8AtUtf8 16) hexBuilder+ <> BFB.contramapBuilder (word8AtUtf8 8) hexBuilder+ <> BFB.contramapBuilder (word8AtUtf8 0) hexBuilder {-# INLINE fixedBuilderNoSeparatorUtf8 #-} word8AtUtf8 :: Int -> Mac -> Word8@@ -604,81 +788,88 @@ word12AtUtf8 i (Mac w) = fromIntegral (unsafeShiftR w i) {-# INLINE word12AtUtf8 #-} --- | A 48-bit MAC address. Do not use the data constructor for this--- type. It is not considered part of the stable API, and it--- allows you to construct invalid MAC addresses.-newtype Mac = Mac Word64- deriving (Eq,Ord,Generic)--instance NFData Mac---- | This only preserves the lower 6 bytes of the 8-byte word that backs a mac address.--- It runs slower than it would if it used a full 8-byte word, but it consumes less--- space. When storing millions of mac addresses, this is a good trade to make. When--- storing a small number of mac address, it might be preferable to make a primitive--- array of 'Word64' instead and use the mac address data constructor to coerce between--- the two.+{- | This only preserves the lower 6 bytes of the 8-byte word that backs a mac address.+It runs slower than it would if it used a full 8-byte word, but it consumes less+space. When storing millions of mac addresses, this is a good trade to make. When+storing a small number of mac address, it might be preferable to make a primitive+array of 'Word64' instead and use the mac address data constructor to coerce between+the two.+-} instance Prim Mac where sizeOf# _ = 6# alignment# _ = 2#- indexByteArray# arr i0 = macFromWord16#- (indexWord16Array# arr i)- (indexWord16Array# arr (i +# 1#))- (indexWord16Array# arr (i +# 2#))- where !i = 3# *# i0- readByteArray# arr i0 s0 = case readWord16Array# arr i s0 of- (# s1, a #) -> case readWord16Array# arr (i +# 1#) s1 of- (# s2, b #) -> case readWord16Array# arr (i +# 2#) s2 of+ indexByteArray# arr i0 =+ macFromWord16#+ (Compat.indexWord16Array# arr i)+ (Compat.indexWord16Array# arr (i +# 1#))+ (Compat.indexWord16Array# arr (i +# 2#))+ where+ !i = 3# *# i0+ readByteArray# arr i0 s0 = case Compat.readWord16Array# arr i s0 of+ (# s1, a #) -> case Compat.readWord16Array# arr (i +# 1#) s1 of+ (# s2, b #) -> case Compat.readWord16Array# arr (i +# 2#) s2 of (# s3, c #) -> (# s3, macFromWord16# a b c #)- where !i = 3# *# i0- writeByteArray# arr i0 m s0 = case writeWord16Array# arr i (macToWord16A# m) s0 of- s1 -> case writeWord16Array# arr (i +# 1#) (macToWord16B# m) s1 of- s2 -> writeWord16Array# arr (i +# 2#) (macToWord16C# m) s2- where !i = 3# *# i0- indexOffAddr# arr i0 = macFromWord16#- (indexWord16OffAddr# arr i)- (indexWord16OffAddr# arr (i +# 1#))- (indexWord16OffAddr# arr (i +# 2#))- where !i = 3# *# i0- readOffAddr# arr i0 s0 = case readWord16OffAddr# arr i s0 of- (# s1, a #) -> case readWord16OffAddr# arr (i +# 1#) s1 of- (# s2, b #) -> case readWord16OffAddr# arr (i +# 2#) s2 of+ where+ !i = 3# *# i0+ writeByteArray# arr i0 m s0 = case Compat.writeWord16Array# arr i (macToWord16A# m) s0 of+ s1 -> case Compat.writeWord16Array# arr (i +# 1#) (macToWord16B# m) s1 of+ s2 -> Compat.writeWord16Array# arr (i +# 2#) (macToWord16C# m) s2+ where+ !i = 3# *# i0+ indexOffAddr# arr i0 =+ macFromWord16#+ (Compat.indexWord16OffAddr# arr i)+ (Compat.indexWord16OffAddr# arr (i +# 1#))+ (Compat.indexWord16OffAddr# arr (i +# 2#))+ where+ !i = 3# *# i0+ readOffAddr# arr i0 s0 = case Compat.readWord16OffAddr# arr i s0 of+ (# s1, a #) -> case Compat.readWord16OffAddr# arr (i +# 1#) s1 of+ (# s2, b #) -> case Compat.readWord16OffAddr# arr (i +# 2#) s2 of (# s3, c #) -> (# s3, macFromWord16# a b c #)- where !i = 3# *# i0- writeOffAddr# arr i0 m s0 = case writeWord16OffAddr# arr i (macToWord16A# m) s0 of- s1 -> case writeWord16OffAddr# arr (i +# 1#) (macToWord16B# m) s1 of- s2 -> writeWord16OffAddr# arr (i +# 2#) (macToWord16C# m) s2- where !i = 3# *# i0+ where+ !i = 3# *# i0+ writeOffAddr# arr i0 m s0 = case Compat.writeWord16OffAddr# arr i (macToWord16A# m) s0 of+ s1 -> case Compat.writeWord16OffAddr# arr (i +# 1#) (macToWord16B# m) s1 of+ s2 -> Compat.writeWord16OffAddr# arr (i +# 2#) (macToWord16C# m) s2+ where+ !i = 3# *# i0 setByteArray# arr# i# len# ident = go 0#- where- go ix# s0 = if isTrue# (ix# <# len#)+ where+ go ix# s0 =+ if isTrue# (ix# <# len#) then case writeByteArray# arr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 setOffAddr# addr# i# len# ident = go 0#- where- go ix# s0 = if isTrue# (ix# <# len#)+ where+ go ix# s0 =+ if isTrue# (ix# <# len#) then case writeOffAddr# addr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 macToWord16A# :: Mac -> Word#+{-# INLINE macToWord16A# #-} macToWord16A# (Mac w) = case word64ToWord16 (unsafeShiftR w 32) of- W16# x -> x- + Compat.W16# x -> x+ macToWord16B# :: Mac -> Word#+{-# INLINE macToWord16B# #-} macToWord16B# (Mac w) = case word64ToWord16 (unsafeShiftR w 16) of- W16# x -> x+ Compat.W16# x -> x macToWord16C# :: Mac -> Word#+{-# INLINE macToWord16C# #-} macToWord16C# (Mac w) = case word64ToWord16 w of- W16# x -> x- + Compat.W16# x -> x+ macFromWord16# :: Word# -> Word# -> Word# -> Mac-macFromWord16# a b c = Mac- $ (unsafeShiftL (word16ToWord64 (W16# a)) 32)- .|. (unsafeShiftL (word16ToWord64 (W16# b)) 16)- .|. (word16ToWord64 (W16# c))+macFromWord16# a b c =+ Mac $+ (unsafeShiftL (word16ToWord64 (Compat.W16# a)) 32)+ .|. (unsafeShiftL (word16ToWord64 (Compat.W16# b)) 16)+ .|. (word16ToWord64 (Compat.W16# c)) word16ToWord64 :: Word16 -> Word64 word16ToWord64 = fromIntegral@@ -692,9 +883,10 @@ -- It also uses the smart constructor instead -- of the actual constructor instance Show Mac where- showsPrec p (Mac addr) = showParen (p > 10)- $ showString "mac "- . showHexWord48 addr+ showsPrec p (Mac addr) =+ showParen (p > 10) $+ showString "mac "+ . showHexWord48 addr instance Read Mac where readPrec = parens $ prec 10 $ do@@ -722,51 +914,62 @@ showHexWord48 :: Word64 -> ShowS showHexWord48 w = showString "0x" . go 11- where+ where go :: Int -> ShowS- go !ix = if ix >= 0- then showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) (ix * 4)) .&. 0xF)) . go (ix - 1)- else id+ go !ix =+ if ix >= 0+ then showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) (ix * 4)) .&. 0xF)) . go (ix - 1)+ else id nibbleToHex :: Word -> Char nibbleToHex w | w < 10 = chr (fromIntegral (w + 48)) | otherwise = chr (fromIntegral (w + 87)) --- | A 'MacCodec' allows users to control the encoding/decoding--- of their 'Mac' addresses.+{- | A 'MacCodec' allows users to control the encoding/decoding+ of their 'Mac' addresses.+-} data MacCodec = MacCodec { macCodecGrouping :: !MacGrouping , macCodecUpperCase :: !Bool- } deriving (Eq,Ord,Show,Read,Generic)+ }+ deriving (Eq, Ord, Show, Read, Generic, Data) --- | The format expected by the mac address parser. The 'Word8' taken--- by some of these constructors is the ascii value of the character--- to be used as the separator. This is typically a colon, a hyphen, or--- a space character. All decoding functions are case insensitive.+{- | The format expected by the mac address parser. The 'Word8' taken+ by some of these constructors is the ascii value of the character+ to be used as the separator. This is typically a colon, a hyphen, or+ a space character. All decoding functions are case insensitive.+-} data MacGrouping- = MacGroupingPairs !Char -- ^ Two-character groups, @FA:2B:40:09:8C:11@- | MacGroupingTriples !Char -- ^ Three-character groups, @24B-F0A-025-829@- | MacGroupingQuadruples !Char -- ^ Four-character groups, @A220.0745.CAC7@- | MacGroupingNoSeparator -- ^ No separator, @24AF4B5B0780@- deriving (Eq,Ord,Show,Read,Generic)--instance Hashable Mac+ = -- | Two-character groups, @FA:2B:40:09:8C:11@+ MacGroupingPairs !Char+ | -- | Three-character groups, @24B-F0A-025-829@+ MacGroupingTriples !Char+ | -- | Four-character groups, @A220.0745.CAC7@+ MacGroupingQuadruples !Char+ | -- | No separator, @24AF4B5B0780@+ MacGroupingNoSeparator+ deriving (Eq, Ord, Show, Read, Generic, Data) instance ToJSON Mac where toJSON = Aeson.String . encode -#if MIN_VERSION_aeson(1,0,0) instance ToJSONKey Mac where- toJSONKey = ToJSONKeyText- encode- (\m -> Aeson.unsafeToEncoding $ BB.char7 '"' <> builderUtf8 m <> BB.char7 '"')+ toJSONKey =+ ToJSONKeyText+ (keyFromText . encode)+ (\m -> Aeson.unsafeToEncoding $ BB.char7 '"' <> builderUtf8 m <> BB.char7 '"')+ where+#if MIN_VERSION_aeson(2,0,0)+ keyFromText = AK.fromText+#else+ keyFromText = id+#endif instance FromJSONKey Mac where fromJSONKey = FromJSONKeyTextParser $ \t -> case decode t of Nothing -> fail "invalid mac address" Just addr -> return addr-#endif instance FromJSON Mac where parseJSON = attoparsecParseJSON parser@@ -776,7 +979,7 @@ case v of Aeson.String t -> case AT.parseOnly p t of- Left err -> fail err+ Left err -> fail err Right res -> return res _ -> fail "expected a String" @@ -784,11 +987,10 @@ -- than 256. unsafeWord48FromOctets :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 unsafeWord48FromOctets a b c d e f =- fromIntegral- $ unsafeShiftL a 40- .|. unsafeShiftL b 32- .|. unsafeShiftL c 24- .|. unsafeShiftL d 16- .|. unsafeShiftL e 8- .|. f-+ fromIntegral $+ unsafeShiftL a 40+ .|. unsafeShiftL b 32+ .|. unsafeShiftL c 24+ .|. unsafeShiftL d 16+ .|. unsafeShiftL e 8+ .|. f
src/Net/Types.hs view
@@ -1,18 +1,16 @@-{-| This module re-exports all of the thematic types that this library defines.--}+-- | This module re-exports all of the thematic types that this library defines. module Net.Types- ( IPv4(..)- , IPv6(..)- , IP(..)- , IPv4Range(..)- , IPv6Range(..)- , Mac(..)- , MacCodec(..)- , MacGrouping(..)+ ( IPv4 (..)+ , IPv6 (..)+ , IP (..)+ , IPv4Range (..)+ , IPv6Range (..)+ , Mac (..)+ , MacCodec (..)+ , MacGrouping (..) ) where -import Net.IPv6 (IPv6(..),IPv6Range(..))-import Net.IPv4 (IPv4(..), IPv4Range(..))-import Net.IP (IP(..))-import Net.Mac (Mac(..),MacCodec(..),MacGrouping(..))-+import Net.IP (IP (..))+import Net.IPv4 (IPv4 (..), IPv4Range (..))+import Net.IPv6 (IPv6 (..), IPv6Range (..))+import Net.Mac (Mac (..), MacCodec (..), MacGrouping (..))
test/Bench.hs view
@@ -1,75 +1,126 @@ module Main (main) where import Criterion.Main-import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..))+import Data.Bool (bool) import Data.Maybe (fromJust)+import Data.Primitive (PrimArray, foldlPrimArray') import qualified Data.Text as Text-import qualified Net.Mac as Mac import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6+import qualified Net.Mac as Mac+import Net.Types (IPv4 (..), MacCodec (..), MacGrouping (..))+import System.Random (mkStdGen, randoms) -import qualified Naive-import qualified IPv4Text1-import qualified IPv4Text2+import qualified Data.Bytes.Text.Ascii as Ascii+import qualified GHC.Exts as Exts import qualified IPv4ByteString1 import qualified IPv4DecodeText1 import qualified IPv4DecodeText2--- import qualified IPv4TextVariableBuilder+import qualified IPv4Text1+import qualified IPv4Text2+import qualified Naive main :: IO () main = do let ipAddr = IPv4 1000000009 ipText = Text.pack "192.168.5.99"+ ipBytes = Ascii.fromString "192.168.5.99" mac = Mac.fromOctets 0xFA 0xBB 0x43 0xA1 0x22 0x09 ip6Text = Text.pack "::" ip6 = fromJust $ IPv6.decode ip6Text- ip6TextBigger = Text.pack "1:2:3:4:5:6:7:8"+ ip6StrBigger = "1:2:3:4:5:6:7:8"+ ip6TextBigger = Text.pack ip6StrBigger+ ip6BytesBigger = Ascii.fromString "1:2:3:4:5:6:7:8" ip6Bigger = fromJust $ IPv6.decode ip6TextBigger+ ip6ComplicatedStr = "2001:db8:ba1:0:aaaa:542c:bb:cc00"+ ip6ComplicatedBytes = Ascii.fromString ip6ComplicatedStr+ ip6Complicated = fromJust $ IPv6.decode (Text.pack ip6ComplicatedStr) ip6TextSkip = Text.pack "1:2::7:8" ip6Skip = fromJust $ IPv6.decode ip6TextSkip ip6TextHex = Text.pack "a:b::c:d" ip6Hex = fromJust $ IPv6.decode ip6TextHex+ hundredAddrs = Exts.fromList (map IPv4 (take 100 (randoms (mkStdGen 42)))) :: PrimArray IPv4 defaultMain- [ bgroup "Mac to Text"- [ bench "Current Implementation, pairs" $ whnf Mac.encode mac- , bench "Current Implementation, no separator"- $ whnf (Mac.encodeWith (MacCodec MacGroupingNoSeparator True)) mac- , bench "Current Implementation, quads"- $ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac- , bench "Current Implementation, triples"- $ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac- ]- , bgroup "Mac to ByteString"- [ bench "Current Implementation, pairs" $ whnf Mac.encodeUtf8 mac- , bench "Current Implementation, no separator"- $ whnf (Mac.encodeWithUtf8 (MacCodec MacGroupingNoSeparator True)) mac- ]- , bgroup "IPv4 to Text"- [ bench "Naive" $ whnf Naive.encodeText ipAddr- , bench "Text Builder" $ whnf IPv4Text2.encode ipAddr- , bench "Preallocated" $ whnf IPv4Text1.encode ipAddr- -- , bench "Variable Builder" $ whnf IPv4TextVariableBuilder.encode ipAddr- ]- , bgroup "IPv4 from Text"- [ bench "Naive" $ whnf Naive.decodeText ipText- , bench "Attoparsec" $ whnf IPv4DecodeText2.decodeText ipText- , bench "Text Reader" $ whnf IPv4DecodeText1.decodeText ipText- ]- , bgroup "IPv4 to ByteString"- [ bench "Naive" $ whnf Naive.encodeByteString ipAddr- , bench "Preallocated: No Lookup Tables" $ whnf IPv4ByteString1.encode ipAddr- , bench "Preallocated" $ whnf IPv4.encodeUtf8 ipAddr- ]- , bgroup "IPv6 to Text"- [ bench "New '::'" $ whnf IPv6.decode ip6Text- , bench "New '1:2:3:4:5:6:7:8'" $ whnf IPv6.decode ip6TextBigger- , bench "New '1:2::7:8'" $ whnf IPv6.decode ip6TextSkip- , bench "New 'a:b::c:d'" $ whnf IPv6.decode ip6TextHex- ]- , bgroup "IPv6 from Text"- [ bench "New '::'" $ whnf IPv6.encode ip6- , bench "New '1:2:3:4:5:6:7:8'" $ whnf IPv6.encode ip6Bigger- , bench "New '1:2::7:8'" $ whnf IPv6.encode ip6Skip- , bench "New 'a:b::c:d'" $ whnf IPv6.encode ip6Hex- ]+ [ bgroup+ "Mac to Text"+ [ bench "Current Implementation, pairs" $ whnf Mac.encode mac+ , bench "Current Implementation, no separator" $+ whnf (Mac.encodeWith (MacCodec MacGroupingNoSeparator True)) mac+ , bench "Current Implementation, quads" $+ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac+ , bench "Current Implementation, triples" $+ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac+ ]+ , bgroup+ "Mac to ByteString"+ [ bench "Current Implementation, pairs" $ whnf Mac.encodeUtf8 mac+ , bench "Current Implementation, no separator" $+ whnf (Mac.encodeWithUtf8 (MacCodec MacGroupingNoSeparator True)) mac+ ]+ , bgroup+ "IPv4 to ShortText"+ [ bench "Implementation" $ whnf IPv4.encodeShort ipAddr+ ]+ , bgroup+ "IPv4 to Text"+ [ bench "Naive" $ whnf Naive.encodeText ipAddr+ , bench "Text Builder" $ whnf IPv4Text2.encode ipAddr+ , bench "Preallocated" $ whnf IPv4Text1.encode ipAddr+ -- , bench "Variable Builder" $ whnf IPv4TextVariableBuilder.encode ipAddr+ ]+ , bgroup+ "IPv4 from Text"+ [ bench "Naive" $ whnf Naive.decodeText ipText+ , bench "Attoparsec" $ whnf IPv4DecodeText2.decodeText ipText+ , bench "Text Reader" $ whnf IPv4DecodeText1.decodeText ipText+ ]+ , bgroup+ "IPv4 from Bytes"+ [ bench "Current" $ whnf IPv4.decodeUtf8Bytes ipBytes+ ]+ , bgroup+ "IPv4 to ByteString"+ [ bench "Naive" $ whnf Naive.encodeByteString ipAddr+ , bench "Preallocated: No Lookup Tables" $ whnf IPv4ByteString1.encode ipAddr+ , bench "Preallocated" $ whnf IPv4.encodeUtf8 ipAddr+ ]+ , bgroup+ "IPv6 from Text"+ [ bench "::" $ whnf IPv6.decode ip6Text+ , bench "1:2:3:4:5:6:7:8" $ whnf IPv6.decode ip6TextBigger+ , bench "1:2::7:8" $ whnf IPv6.decode ip6TextSkip+ , bench "a:b::c:d" $ whnf IPv6.decode ip6TextHex+ ]+ , bgroup+ "IPv6 bytesmith"+ [ bench "1:2:3:4:5:6:7:8" $ whnf IPv6.decodeUtf8Bytes ip6BytesBigger+ , bench "2001:db8:ba1:0:aaaa:542c:bb:cc00" $ whnf IPv6.decodeUtf8Bytes ip6ComplicatedBytes+ ]+ , bgroup+ "IPv6 to Text"+ [ bench "::" $ whnf IPv6.encode ip6+ , bench "1:2:3:4:5:6:7:8" $ whnf IPv6.encode ip6Bigger+ , bench "1:2::7:8" $ whnf IPv6.encode ip6Skip+ , bench "a:b::c:d" $ whnf IPv6.encode ip6Hex+ ]+ , bgroup+ "IPv6 to ShortText"+ [ bench "1:2:3:4:5:6:7:8" $ whnf IPv6.encodeShort ip6Bigger+ , bench "1:2::7:8" $ whnf IPv6.encodeShort ip6Skip+ , bench "a:b::c:d" $ whnf IPv6.encodeShort ip6Hex+ , bench "2001:db8:ba1:0:aaaa:542c:bb:cc00" $ whnf IPv6.encodeShort ip6Complicated+ ]+ , bgroup+ "CIDR Inclusion"+ [ bench "reserved" $ whnf manyReserved hundredAddrs+ , bench "private" $ whnf manyPrivate hundredAddrs+ ] ]++manyReserved :: PrimArray IPv4 -> Int+{-# NOINLINE manyReserved #-}+manyReserved x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.reserved addr) + acc) 0 x++manyPrivate :: PrimArray IPv4 -> Int+{-# NOINLINE manyPrivate #-}+manyPrivate x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.private addr) + acc) 0 x
− test/Doctests.hs
@@ -1,14 +0,0 @@-import Test.DocTest--main :: IO ()-main = doctest- [ "src/Net/IPv4.hs"- , "src/Net/IPv6.hs"- , "src/Net/IP.hs"- , "src/Data/Word/Synthetic/Word12.hs"- , "src/Data/Text/Builder/Common/Internal.hs"- , "src/Data/Text/Builder/Fixed.hs"- , "src/Data/ByteString/Builder/Fixed.hs"- , "src/Net/Mac.hs"- , "-XCPP"- ]
test/IPv4ByteString1.hs view
@@ -1,43 +1,48 @@ module IPv4ByteString1 where -import Net.Types (IPv4(..))+import Net.Types (IPv4 (..)) -import Data.ByteString.Internal as I import Data.Bits+import Data.ByteString.Internal as I+import Data.Word import Foreign.Ptr import Foreign.Storable-import Data.Word encode :: IPv4 -> ByteString-encode (IPv4 w) = I.unsafeCreateUptoN 15 (\ptr1 ->- do (len1,ptr2) <- writeWord ptr1 w1- poke ptr2 dot- (len2,ptr3) <- writeWord (ptr2 `plusPtr` 1) w2- poke ptr3 dot- (len3,ptr4) <- writeWord (ptr3 `plusPtr` 1) w3- poke ptr4 dot- (len4,_) <- writeWord (ptr4 `plusPtr` 1) w4- return (3 + len1 + len2 + len3 + len4))- where w1 = fromIntegral $ shiftR w 24- w2 = fromIntegral $ shiftR w 16- w3 = fromIntegral $ shiftR w 8- w4 = fromIntegral w- dot = 46- writeWord :: Ptr Word8 -> Word8 -> IO (Int,Ptr Word8)- writeWord ptr word- | word >= 100 = do- let (word1,char3) = word `quotRem` 10- (char1,char2) = word1 `quotRem` 10- poke ptr (char1 + 48)- poke (ptr `plusPtr` 1) (char2 + 48)- poke (ptr `plusPtr` 2) (char3 + 48)- return (3,ptr `plusPtr` 3)- | word >= 10 = do- let (char1,char2) = word `quotRem` 10- poke ptr (char1 + 48)- poke (ptr `plusPtr` 1) (char2 + 48)- return (2,ptr `plusPtr` 2)- | otherwise = do- poke ptr (word + 48)- return (1,ptr `plusPtr` 1)-+encode (IPv4 w) =+ I.unsafeCreateUptoN+ 15+ ( \ptr1 ->+ do+ (len1, ptr2) <- writeWord ptr1 w1+ poke ptr2 dot+ (len2, ptr3) <- writeWord (ptr2 `plusPtr` 1) w2+ poke ptr3 dot+ (len3, ptr4) <- writeWord (ptr3 `plusPtr` 1) w3+ poke ptr4 dot+ (len4, _) <- writeWord (ptr4 `plusPtr` 1) w4+ return (3 + len1 + len2 + len3 + len4)+ )+ where+ w1 = fromIntegral $ shiftR w 24+ w2 = fromIntegral $ shiftR w 16+ w3 = fromIntegral $ shiftR w 8+ w4 = fromIntegral w+ dot = 46+ writeWord :: Ptr Word8 -> Word8 -> IO (Int, Ptr Word8)+ writeWord ptr word+ | word >= 100 = do+ let (word1, char3) = word `quotRem` 10+ (char1, char2) = word1 `quotRem` 10+ poke ptr (char1 + 48)+ poke (ptr `plusPtr` 1) (char2 + 48)+ poke (ptr `plusPtr` 2) (char3 + 48)+ return (3, ptr `plusPtr` 3)+ | word >= 10 = do+ let (char1, char2) = word `quotRem` 10+ poke ptr (char1 + 48)+ poke (ptr `plusPtr` 1) (char2 + 48)+ return (2, ptr `plusPtr` 2)+ | otherwise = do+ poke ptr (word + 48)+ return (1, ptr `plusPtr` 1)
test/IPv4DecodeText1.hs view
@@ -1,30 +1,31 @@ module IPv4DecodeText1 where -import Net.Types-import Data.Word-import Data.Text.Internal (Text(..)) import Control.Monad-import Data.Bits ((.|.),shiftL)-import qualified Data.Text as Text-import qualified Data.Text.Read as TextRead+import Data.Bits (shiftL, (.|.))+import qualified Data.Text as Text+import Data.Text.Internal (Text (..))+import qualified Data.Text.Read as TextRead+import Data.Word+import Net.Types stripDecimal :: Text -> Either String Text stripDecimal t = case Text.uncons t of Nothing -> Left "expected a dot but input ended instead"- Just (c,tnext) -> if c == '.'- then Right tnext- else Left "expected a dot but found a different character"+ Just (c, tnext) ->+ if c == '.'+ then Right tnext+ else Left "expected a dot but found a different character" {-# INLINE stripDecimal #-} decodeIPv4TextEither :: Text -> Either String Word32 decodeIPv4TextEither t1' = do- (a,t2) <- TextRead.decimal t1'+ (a, t2) <- TextRead.decimal t1' t2' <- stripDecimal t2- (b,t3) <- TextRead.decimal t2'+ (b, t3) <- TextRead.decimal t2' t3' <- stripDecimal t3- (c,t4) <- TextRead.decimal t3'+ (c, t4) <- TextRead.decimal t3' t4' <- stripDecimal t4- (d,t5) <- TextRead.decimal t4'+ (d, t5) <- TextRead.decimal t4' when (not (Text.null t5)) (Left "expected end of text but it continued instead") if a > 255 || b > 255 || c > 255 || d > 255 then Left ipOctetSizeErrorMsg@@ -40,8 +41,8 @@ fromOctets' :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 fromOctets' a b c d =- ( shiftL a 24- .|. shiftL b 16- .|. shiftL c 8- .|. d- )+ ( shiftL a 24+ .|. shiftL b 16+ .|. shiftL c 8+ .|. d+ )
test/IPv4DecodeText2.hs view
@@ -1,21 +1,22 @@ module IPv4DecodeText2 where -import Net.Types+import qualified Data.Attoparsec.Text as AT+import Data.Bits (shiftL, (.|.))+import Data.Text.Internal (Text (..)) import Data.Word-import Data.Bits (shiftL,(.|.))-import Data.Text.Internal (Text(..))-import qualified Data.Attoparsec.Text as AT+import Net.Types dotDecimalParser :: AT.Parser Word32-dotDecimalParser = fromOctets'- <$> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- <* AT.char '.'- <*> (AT.decimal >>= limitSize)- where+dotDecimalParser =+ fromOctets'+ <$> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ <* AT.char '.'+ <*> (AT.decimal >>= limitSize)+ where limitSize i = if i > 255 then fail ipOctetSizeErrorMsg@@ -31,8 +32,8 @@ fromOctets' :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 fromOctets' a b c d =- ( shiftL a 24- .|. shiftL b 16- .|. shiftL c 8- .|. d- )+ ( shiftL a 24+ .|. shiftL b 16+ .|. shiftL c 8+ .|. d+ )
test/IPv4Text1.hs view
@@ -1,17 +1,18 @@+{-# LANGUAGE CPP #-}+ module IPv4Text1 where -import Net.Types (IPv4(..))-import Data.Text (Text)-import Data.Monoid ((<>))-import Data.Text.Internal (Text(..))-import Data.Word-import Data.ByteString (ByteString) import Control.Monad.ST-import Data.Bits (shiftR,(.&.))-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString as ByteString+import Data.Bits (shiftR, (.&.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Array as TArray+import Data.Text (Text)+import qualified Data.Text.Array as TArray+import Data.Text.Internal (Text (..))+import Data.Word+import Net.Types (IPv4 (..)) ------------------------ -- This implementation operates directly on@@ -27,7 +28,7 @@ w2 = fromIntegral $ 255 .&. shiftR w 16 w3 = fromIntegral $ 255 .&. shiftR w 8 w4 = fromIntegral $ 255 .&. w- (arr,len) = runST $ do+ (arr, len) = runST $ do marr <- TArray.new 15 i1 <- putAndCount 0 w1 marr let n1 = i1@@ -43,15 +44,15 @@ TArray.unsafeWrite marr n3 dot i4 <- putAndCount n3' w4 marr theArr <- TArray.unsafeFreeze marr- return (theArr,i4 + n3')- in Text arr 0 len+ return (theArr, i4 + n3')+ in Text arr 0 len putAndCount :: Int -> Word8 -> TArray.MArray s -> ST s Int putAndCount pos w marr | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1 | w < 100 = write2 pos w >> return 2 | otherwise = write3 pos w >> return 3- where+ where write2 off i0 = do let i = fromIntegral i0; j = i + i TArray.unsafeWrite marr off $ get2 j@@ -64,37 +65,47 @@ get2 = fromIntegral . ByteString.unsafeIndex twoDigits get3 = fromIntegral . ByteString.unsafeIndex threeDigits -zero,dot :: Word16+-- From Common.Compat, but we don't want to expose the module so we also+-- define 'Codepoint' here.+#if MIN_VERSION_text(2, 0, 0)+type Codepoint = Word8+#else+type Codepoint = Word16+#endif++zero, dot :: Codepoint zero = 48 {-# INLINE zero #-} dot = 46 {-# INLINE dot #-} -i2w :: (Integral a) => a -> Word16+i2w :: (Integral a) => a -> Codepoint i2w v = zero + fromIntegral v {-# INLINE i2w #-} +-- Note: these double backslashes are need here because CPP is enabled.+{- FOURMOLU_DISABLE -} twoDigits :: ByteString twoDigits = BC8.pack- "0001020304050607080910111213141516171819\- \2021222324252627282930313233343536373839\- \4041424344454647484950515253545556575859\- \6061626364656667686970717273747576777879\+ "0001020304050607080910111213141516171819\\+ \2021222324252627282930313233343536373839\\+ \4041424344454647484950515253545556575859\\+ \6061626364656667686970717273747576777879\\ \8081828384858687888990919293949596979899" threeDigits :: ByteString threeDigits = ByteString.replicate 300 0 <> BC8.pack- "100101102103104105106107108109110111112\- \113114115116117118119120121122123124125\- \126127128129130131132133134135136137138\- \139140141142143144145146147148149150151\- \152153154155156157158159160161162163164\- \165166167168169170171172173174175176177\- \178179180181182183184185186187188189190\- \191192193194195196197198199200201202203\- \204205206207208209210211212213214215216\- \217218219220221222223224225226227228229\- \230231232233234235236237238239240241242\+ "100101102103104105106107108109110111112\\+ \113114115116117118119120121122123124125\\+ \126127128129130131132133134135136137138\\+ \139140141142143144145146147148149150151\\+ \152153154155156157158159160161162163164\\+ \165166167168169170171172173174175176177\\+ \178179180181182183184185186187188189190\\+ \191192193194195196197198199200201202203\\+ \204205206207208209210211212213214215216\\+ \217218219220221222223224225226227228229\\+ \230231232233234235236237238239240241242\\ \243244245246247248249250251252253254255"-+{- FOURMOLU_ENABLE -}
test/IPv4Text2.hs view
@@ -1,12 +1,11 @@ module IPv4Text2 where -import Net.Types (IPv4(..))+import Data.Bits (shiftR, (.&.)) import Data.Text (Text)-import Data.Bits ((.&.),shiftR)-import Data.Monoid ((<>))-import Data.Text.Lazy.Builder.Int (decimal)-import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as TBuilder+import Data.Text.Lazy.Builder.Int (decimal)+import Net.Types (IPv4 (..)) ----------------------------------------- -- Text Builder implementation. This ends@@ -18,13 +17,13 @@ toDotDecimalBuilder :: IPv4 -> TBuilder.Builder toDotDecimalBuilder (IPv4 w) =- decimal (255 .&. shiftR w 24 )- <> dot- <> decimal (255 .&. shiftR w 16 )- <> dot- <> decimal (255 .&. shiftR w 8 )- <> dot- <> decimal (255 .&. w)- where dot = TBuilder.singleton '.'+ decimal (255 .&. shiftR w 24)+ <> dot+ <> decimal (255 .&. shiftR w 16)+ <> dot+ <> decimal (255 .&. shiftR w 8)+ <> dot+ <> decimal (255 .&. w)+ where+ dot = TBuilder.singleton '.' {-# INLINE toDotDecimalBuilder #-}-
test/Naive.hs view
@@ -1,31 +1,33 @@ module Naive where -import Net.Types (IPv4(..))+import Data.ByteString (ByteString) import Data.Text (Text)-import qualified Net.IPv4 as IPv4 import qualified Data.Text as Text-import Text.Read (readMaybe)-import Data.ByteString (ByteString) import Data.Text.Encoding (encodeUtf8)+import qualified Net.IPv4 as IPv4+import Net.Types (IPv4 (..))+import Text.Read (readMaybe) encodeByteString :: IPv4 -> ByteString encodeByteString = encodeUtf8 . encodeText encodeText :: IPv4 -> Text-encodeText i = Text.pack $ concat- [ show a- , "."- , show b- , "."- , show c- , "."- , show d- ]- where (a,b,c,d) = IPv4.toOctets i+encodeText i =+ Text.pack $+ concat+ [ show a+ , "."+ , show b+ , "."+ , show c+ , "."+ , show d+ ]+ where+ (a, b, c, d) = IPv4.toOctets i decodeText :: Text -> Maybe IPv4 decodeText t = case mapM (readMaybe . Text.unpack) (Text.splitOn (Text.pack ".") t) of- Just [a,b,c,d] -> Just (IPv4.fromOctets a b c d)+ Just [a, b, c, d] -> Just (IPv4.fromOctets a b c d) _ -> Nothing-
− test/Net/IPv4/RangeSpec.hs
@@ -1,67 +0,0 @@-{-# OPTIONS_GHC -Wno-deprecations #-}-module Net.IPv4.RangeSpec (spec) where-import Prelude hiding (any)-import Data.Bits-import Net.IPv4-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]
test/Net/IPv4Spec.hs view
@@ -1,68 +1,99 @@ {-# OPTIONS_GHC -Wno-deprecations #-}+ module Net.IPv4Spec (spec) where-import Prelude hiding (any)+ import Data.Bits import Net.IPv4 import Test.Hspec+import Prelude hiding (any) 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+ 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` [ 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+ , True+ , True+ , True+ , True+ , True+ , True+ , False+ ]+ it "bit" $ do+ bit 0 `shouldBe` ipv4 0 0 0 1+ bit 1 `shouldBe` ipv4 0 0 0 2+ bit 31 `shouldBe` ipv4 128 0 0 0+ 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
test/Test.hs view
@@ -1,177 +1,311 @@-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Main (main) where -import Naive+#if MIN_VERSION_base(4,18,0)+#else 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.HUnit (Assertion,(@?=),(@=?))-import Numeric (showHex)-import Test.QuickCheck.Property (failed,succeeded,Result(..))+#endif+ import Data.Bifunctor-import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws,bitsLaws,primLaws,boundedEnumLaws)-import qualified Test.Framework.Providers.HUnit as PH+import Data.Bytes (Bytes)+import Data.Proxy (Proxy (..))+import Naive+import Numeric (showHex)+import Test.HUnit (Assertion, (@=?), (@?=))+import Test.QuickCheck (Arbitrary (..), Gen, choose, elements, oneof, (===))+import Test.QuickCheck.Classes (Laws (..), bitsLaws, boundedEnumLaws, jsonLaws, primLaws, showReadLaws)+import Test.QuickCheck.Property (Result (..), failed, succeeded)+import Test.Tasty (TestTree, defaultMain, testGroup)+import qualified Test.Tasty.HUnit as PH+import Test.Tasty.QuickCheck (testProperty) -import Net.Types (IP,IPv4(..),IPv4Range(..),Mac(..),IPv6(..),MacGrouping(..),MacCodec(..),IPv6Range(..))-import Data.WideWord (Word128(..))-import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BC8+import qualified Data.Bytes.Text.Ascii as Ascii+import qualified Data.Text as Text+import qualified Data.Text.Short as TS+import Data.WideWord (Word128 (..))+import qualified Net.IP as IP import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 import qualified Net.Mac as Mac-import qualified Net.IP as IP+import Net.Types (IP, IPv4 (..), IPv4Range (..), IPv6 (..), IPv6Range (..), Mac (..), MacCodec (..), MacGrouping (..)) -import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.ByteString as AB+import qualified Data.Attoparsec.Text as AT +import qualified IPv4ByteString1 import qualified IPv4Text1 import qualified IPv4Text2-import qualified IPv4ByteString1+ -- import qualified IPv4TextVariableBuilder main :: IO () main = defaultMain tests -tests :: [Test]+tests :: TestTree tests =- [ testGroup "Encoding and Decoding"- [ testGroup "Currently used IPv4 encode/decode" $- [ testProperty "Isomorphism"- $ propEncodeDecodeIso IPv4.encode IPv4.decode- , PH.testCase "Decode an IP" testIPv4Decode- ] ++ testDecodeFailures- , testGroup "Currently used MAC Text encode/decode"- [ testProperty "Isomorphism"- $ propEncodeDecodeIsoSettings Mac.encodeWith Mac.decodeWith- , PH.testCase "Encode a MAC Address" testMacEncode- ]- , testGroup "Currently used MAC ByteString encode/decode"- [ testProperty "Isomorphism"- $ propEncodeDecodeIsoSettings Mac.encodeWithUtf8 Mac.decodeWithUtf8- , PH.testCase "Lenient Decoding" testLenientMacByteStringParser- ]- , testGroup "Naive IPv4 encode/decode"- [ testProperty "Isomorphism"- $ propEncodeDecodeIso Naive.encodeText Naive.decodeText- ]- , testGroup "Text Builder IPv4 Text encode/decode"- [ testProperty "Identical to Naive"- $ propMatching IPv4Text2.encode Naive.encodeText- ]- -- , testGroup "Variable Text Builder IPv4 Text encode/decode"- -- [ testProperty "Identical to Naive"- -- $ propMatching IPv4TextVariableBuilder.encode Naive.encodeText- -- ]- , testGroup "Raw byte array IPv4 Text encode/decode"- [ testProperty "Identical to Naive"- $ propMatching IPv4Text1.encode Naive.encodeText- ]- , testGroup "Raw byte array (without lookup table) IPv4 ByteString encode/decode"- [ testProperty "Identical to Naive"- $ propMatching IPv4ByteString1.encode Naive.encodeByteString- ]- , testGroup "Raw byte array (with lookup table) IPv4 ByteString encode/decode"- [ testProperty "Identical to Naive"- $ propMatching IPv4.encodeUtf8 Naive.encodeByteString- ]- , testGroup "IPv4 encode/decode"- [ PH.testCase "Parser Test Cases" testIPv4Parser- ]- , testGroup "IPv6 encode/decode"- [ PH.testCase "Parser Test Cases" testIPv6Parser- , PH.testCase "Encode test cases" testIPv6Encode- , PH.testCase "Parser Failure Test Cases" testIPv6ParserFailure- ]- ]- , testGroup "IPv4 Range Operations"- [ testProperty "Idempotence of normalizing IPv4 range"- $ 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))- , 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))- , lawsToTest (showReadLaws (Proxy :: Proxy IPv6))- , lawsToTest (primLaws (Proxy :: Proxy IPv6))- , lawsToTest (boundedEnumLaws (Proxy :: Proxy IPv6))- ]- , testGroup "IP"- [ lawsToTest (jsonLaws (Proxy :: Proxy IP))- , lawsToTest (showReadLaws (Proxy :: Proxy IP))- ]- , testGroup "Mac"- [ lawsToTest (jsonLaws (Proxy :: Proxy Mac))- , lawsToTest (showReadLaws (Proxy :: Proxy Mac))- , lawsToTest (primLaws (Proxy :: Proxy Mac))- ]+ testGroup+ "tests"+ [ testGroup+ "Encoding and Decoding"+ [ testGroup "Currently used IPv4 encode/decode" $+ [ testProperty "Isomorphism" $+ propEncodeDecodeIso IPv4.encode IPv4.decode+ , PH.testCase "Decode an IP" testIPv4Decode+ ]+ ++ testDecodeFailures+ , testGroup "Currently used IPv4 encodeShort/decodeShort" $+ [ testProperty "Isomorphism" $+ propEncodeDecodeIso IPv4.encodeShort IPv4.decodeShort+ ]+ ++ testDecodeFailures+ , testGroup+ "Currently used IPv4 UTF-8 Bytes decode"+ [ testProperty "Isomorphism" $+ propEncodeDecodeIso (byteStringToBytes . IPv4.encodeUtf8) IPv4.decodeUtf8Bytes+ , PH.testCase "Encode a MAC Address" testMacEncode+ ]+ , testGroup+ "Currently used MAC Text encode/decode"+ [ testProperty "Isomorphism" $+ propEncodeDecodeIsoSettings Mac.encodeWith Mac.decodeWith+ , PH.testCase "Encode a MAC Address" testMacEncode+ ]+ , testGroup+ "Currently used MAC ByteString encode/decode"+ [ testProperty "Isomorphism" $+ propEncodeDecodeIsoSettings Mac.encodeWithUtf8 Mac.decodeWithUtf8+ , PH.testCase "Lenient Decoding" testLenientMacByteStringParser+ ]+ , testGroup+ "Naive IPv4 encode/decode"+ [ testProperty "Isomorphism" $+ propEncodeDecodeIso Naive.encodeText Naive.decodeText+ ]+ , testGroup+ "Text Builder IPv4 Text encode/decode"+ [ testProperty "Identical to Naive" $+ propMatching IPv4Text2.encode Naive.encodeText+ ]+ , -- , testGroup "Variable Text Builder IPv4 Text encode/decode"+ -- [ testProperty "Identical to Naive"+ -- $ propMatching IPv4TextVariableBuilder.encode Naive.encodeText+ -- ]+ testGroup+ "Raw byte array IPv4 Text encode/decode"+ [ testProperty "Identical to Naive" $+ propMatching IPv4Text1.encode Naive.encodeText+ ]+ , testGroup+ "Raw byte array (without lookup table) IPv4 ByteString encode/decode"+ [ testProperty "Identical to Naive" $+ propMatching IPv4ByteString1.encode Naive.encodeByteString+ ]+ , testGroup+ "Raw byte array (with lookup table) IPv4 ByteString encode/decode"+ [ testProperty "Identical to Naive" $+ propMatching IPv4.encodeUtf8 Naive.encodeByteString+ ]+ , testGroup+ "IPv4 encode/decode"+ [ PH.testCase "Parser Test Cases" testIPv4Parser+ ]+ , testGroup+ "IPv6 encode/decode"+ [ PH.testCase "Parser Test Cases" $ testIPv6Parser $ \str ->+ either+ (\_ -> Nothing)+ (Just . HexIPv6)+ ( AT.parseOnly+ (IPv6.parser <* AT.endOfInput)+ (Text.pack str)+ )+ , PH.testCase "Bytes Parser Test Cases" $ testIPv6Parser $ \str ->+ fmap HexIPv6 (IPv6.decodeUtf8Bytes (Ascii.fromString str))+ , PH.testCase "Encode test cases" (testIPv6Encode IPv6.encode)+ , PH.testCase "Encode ShortText" (testIPv6Encode (TS.toText . IPv6.encodeShort))+ , PH.testCase+ "Parser Failure Test Cases"+ (testIPv6ParserFailure expectIPv6ParserFailure)+ , PH.testCase+ "Bytes Parser Failure Test Cases"+ (testIPv6ParserFailure expectIPv6BytesParserFailure)+ ]+ ]+ , testGroup+ "IPv4 Range Operations"+ [ testProperty "Idempotence of normalizing IPv4 range" $+ propIdempotence IPv4.normalize+ , testProperty "Normalize does not affect membership" propNormalizeMember+ , testProperty "Membership agrees with bounds" propMemberUpperLower+ , testProperty "Range contains self" propRangeSelf+ , testGroup+ "reserved"+ [ PH.testCase "A" $ IPv4.reserved (IPv4.ipv4 0 1 2 3) @=? True+ , PH.testCase "B" $ IPv4.reserved (IPv4.ipv4 1 0 0 0) @=? False+ , PH.testCase "C" $ IPv4.reserved (IPv4.ipv4 100 64 0 3) @=? True+ , PH.testCase "D" $ IPv4.reserved (IPv4.ipv4 127 255 255 255) @=? True+ , PH.testCase "E" $ IPv4.reserved (IPv4.ipv4 110 0 0 255) @=? False+ , PH.testCase "F" $ IPv4.reserved (IPv4.ipv4 192 0 2 255) @=? True+ , PH.testCase "G" $ IPv4.reserved (IPv4.ipv4 203 0 113 0) @=? True+ , PH.testCase "H" $ IPv4.reserved (IPv4.ipv4 225 0 0 0) @=? True+ , PH.testCase "I" $ IPv4.reserved (IPv4.ipv4 226 0 0 0) @=? True+ , PH.testCase "J" $ IPv4.reserved (IPv4.ipv4 255 255 255 254) @=? True+ , PH.testCase "K" $ IPv4.reserved (IPv4.ipv4 255 255 255 255) @=? True+ , PH.testCase "L" $ IPv4.reserved (IPv4.ipv4 224 0 0 0) @=? True+ , PH.testCase "M" $ IPv4.reserved (IPv4.ipv4 239 255 255 255) @=? True+ , PH.testCase "N" $ IPv4.reserved (IPv4.ipv4 223 255 255 255) @=? False+ , PH.testCase "O" $ IPv4.reserved (IPv4.ipv4 203 0 114 0) @=? False+ , PH.testCase "P" $ IPv4.reserved (IPv4.ipv4 203 0 112 255) @=? False+ , PH.testCase "Q" $ IPv4.reserved (IPv4.ipv4 203 0 113 255) @=? True+ , PH.testCase "R" $ IPv4.reserved (IPv4.ipv4 192 88 100 0) @=? False+ , PH.testCase "S" $ IPv4.reserved (IPv4.ipv4 192 88 99 0) @=? True+ , PH.testCase "T" $ IPv4.reserved (IPv4.ipv4 192 0 1 0) @=? False+ ]+ , testGroup+ "private"+ [ PH.testCase "A" $ IPv4.private (IPv4.ipv4 198 73 8 38) @=? False+ , PH.testCase "B" $ IPv4.private (IPv4.ipv4 192 168 100 5) @=? True+ , PH.testCase "C" $ IPv4.private (IPv4.ipv4 10 0 0 0) @=? True+ , PH.testCase "D" $ IPv4.private (IPv4.ipv4 10 255 255 255) @=? True+ ]+ ]+ , 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))+ , lawsToTest (showReadLaws (Proxy :: Proxy IPv4))+ , lawsToTest (bitsLaws (Proxy :: Proxy IPv4))+ ]+ , testGroup+ "IPv4Range"+ [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4Range))+ , lawsToTest (showReadLaws (Proxy :: Proxy IPv4Range))+ ]+ , testGroup+ "IPv6"+ [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6))+ , lawsToTest (showReadLaws (Proxy :: Proxy IPv6))+ , lawsToTest (primLaws (Proxy :: Proxy IPv6))+ , lawsToTest (boundedEnumLaws (Proxy :: Proxy IPv6))+ , lawsToTest (bitsLaws (Proxy :: Proxy IPv6))+ ]+ , testGroup+ "IPv6Range"+ [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6Range))+ , lawsToTest (showReadLaws (Proxy :: Proxy IPv6Range))+ ]+ , testGroup+ "IP"+ [ lawsToTest (jsonLaws (Proxy :: Proxy IP))+ , lawsToTest (showReadLaws (Proxy :: Proxy IP))+ ]+ , testGroup+ "Mac"+ [ lawsToTest (jsonLaws (Proxy :: Proxy Mac))+ , lawsToTest (showReadLaws (Proxy :: Proxy Mac))+ , lawsToTest (primLaws (Proxy :: Proxy Mac))+ ]+ ] ]- ] -lawsToTest :: Laws -> Test+lawsToTest :: Laws -> TestTree lawsToTest (Laws name pairs) = testGroup name (map (uncurry testProperty) pairs) -propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool-propEncodeDecodeIso f g a = g (f a) == Just a+propEncodeDecodeIso ::+ (Eq a, Show a, Show b) =>+ (a -> b) ->+ (b -> Maybe a) ->+ a ->+ Result+propEncodeDecodeIso f g a =+ let fa = f a+ gfa = g fa+ in if gfa == Just a+ then succeeded+ else+ failure $+ concat+ [ "x: "+ , show a+ , "\n"+ , "f(x): "+ , show fa+ , "\n"+ , "g(f(x)): "+ , show gfa+ , "\n"+ ] -propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e)- => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result+propEncodeDecodeIsoSettings ::+ (Eq a, Show a, Show b, Show e) =>+ (e -> a -> b) ->+ (e -> b -> Maybe a) ->+ e ->+ a ->+ Result propEncodeDecodeIsoSettings f g e a = let fa = f e a gfa = g e fa in if gfa == Just a then succeeded- else failure $ concat- [ "env: ", show e, "\n"- , "x: ", show a, "\n"- , "f(x): ", show fa, "\n"- , "g(f(x)): ", show gfa, "\n"- ]+ else+ failure $+ concat+ [ "env: "+ , show e+ , "\n"+ , "x: "+ , show a+ , "\n"+ , "f(x): "+ , show fa+ , "\n"+ , "g(f(x)): "+ , show gfa+ , "\n"+ ] -propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool+propMatching :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool propMatching f g a = f a == g a -propIdempotence :: Eq a => (a -> a) -> a -> Bool+propIdempotence :: (Eq a) => (a -> a) -> a -> Bool propIdempotence f a = f a == f (f a) propNormalizeMember :: IPv4 -> IPv4Range -> Bool@@ -185,71 +319,144 @@ propRangeSelf r = IPv4.member (ipv4RangeBase r) r == True testIPv4Decode :: Assertion-testIPv4Decode = IPv4.decode (Text.pack "124.222.255.0")- @?= Just (IPv4.fromOctets 124 222 255 0)+testIPv4Decode =+ IPv4.decode (Text.pack "124.222.255.0")+ @?= Just (IPv4.fromOctets 124 222 255 0) testLenientMacByteStringParser :: Assertion testLenientMacByteStringParser = do- go 0xAB 0x12 0x0F 0x1C 0x88 0x79- "AB:12:0F:1C:88:79"- go 0xAB 0x12 0x0F 0x0C 0xAA 0x76- "AB1-20F-0CA-A76"- where+ go+ 0xAB+ 0x12+ 0x0F+ 0x1C+ 0x88+ 0x79+ "AB:12:0F:1C:88:79"+ go+ 0xAB+ 0x12+ 0x0F+ 0x0C+ 0xAA+ 0x76+ "AB1-20F-0CA-A76"+ where go a b c d e f str = Just (HexMac (Mac.fromOctets a b c d e f))- @=? fmap HexMac (Mac.decodeUtf8 (BC8.pack str))+ @=? fmap HexMac (Mac.decodeUtf8 (BC8.pack str)) testIPv4Parser :: Assertion testIPv4Parser = do go 202 10 19 54 "202.10.19.54" go 10 202 96 25 "10.202.96.25"- where+ where go a b c d str = Right (IPv4.fromOctets a b c d)- @=? (AB.parseOnly- (IPv4.parserUtf8 <* AT.endOfInput)- (BC8.pack str)- )+ @=? ( AB.parseOnly+ (IPv4.parserUtf8 <* AT.endOfInput)+ (BC8.pack str)+ ) -testIPv6Parser :: Assertion-testIPv6Parser = do+testIPv6Parser :: (String -> Maybe HexIPv6) -> Assertion+testIPv6Parser decode = do -- Basic test- go 0xABCD 0x1234 0xABCD 0x1234 0xDCBA 0x4321 0xFFFF 0xE0E0- "ABCD:1234:ABCD:1234:DCBA:4321:FFFF:E0E0"+ go+ 0xABCD+ 0x1234+ 0xABCD+ 0x1234+ 0xDCBA+ 0x4321+ 0xFFFF+ 0xE0E0+ "ABCD:1234:ABCD:1234:DCBA:4321:FFFF:E0E0" -- Tests that leading zeros can be omitted- go 0x1234 0x5678 0x9ABC 0xDEF0 0x0123 0x4567 0x89AB 0xCDEF- "1234:5678:9ABC:DEF0:123:4567:89AB:CDEF"+ go+ 0x1234+ 0x5678+ 0x9ABC+ 0xDEF0+ 0x0123+ 0x4567+ 0x89AB+ 0xCDEF+ "1234:5678:9ABC:DEF0:123:4567:89AB:CDEF" -- Test that the IPv6 "any" abbreviation works- go 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000- "::"- go 0x1623 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000- "1623::"- go 0x0000 0x0000 0x0000 0x0000 0x0000 0x0000 0xABCD 0x1234- "::ABCD:1234"- go 0xAAAA 0x0000 0x0000 0x0000 0x0000 0x0000 0xABCD 0x1234- "AAAA::ABCD:1234"- go 0xAAAA 0x0000 0x0000 0x0000 0xBBBB 0x0000 0xABCD 0x1234- "AAAA::BBBB:0000:ABCD:1234"- go 0xAAAA 0x0000 0x0000 0x0000 0xBBBB 0x0000 0xABCD 0x1234- "AAAA:0000:0000:0000:BBBB::ABCD:1234"- where+ go+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ "::"+ go+ 0x1623+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ "1623::"+ go+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0xABCD+ 0x1234+ "::ABCD:1234"+ go+ 0xAAAA+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0x0000+ 0xABCD+ 0x1234+ "AAAA::ABCD:1234"+ go+ 0xAAAA+ 0x0000+ 0x0000+ 0x0000+ 0xBBBB+ 0x0000+ 0xABCD+ 0x1234+ "AAAA::BBBB:0000:ABCD:1234"+ go+ 0xAAAA+ 0x0000+ 0x0000+ 0x0000+ 0xBBBB+ 0x0000+ 0xABCD+ 0x1234+ "AAAA:0000:0000:0000:BBBB::ABCD:1234"+ where go a b c d e f g h str =- Right (HexIPv6 (IPv6.fromWord16s a b c d e f g h))- @=? fmap HexIPv6- (AT.parseOnly- (IPv6.parser <* AT.endOfInput)- (Text.pack str)- )+ Just (HexIPv6 (IPv6.fromWord16s a b c d e f g h))+ @=? decode str -testIPv6ParserFailure :: Assertion-testIPv6ParserFailure = do+testIPv6ParserFailure :: (String -> Assertion) -> Assertion+testIPv6ParserFailure go = do -- must not start or end in colon: go ":::" go "1::2:"- go ":1::2"- go "1:::"- go ":1::"- go "::1:"+ go ":1::3"+ go "a:::"+ go ":b::"+ go "::c:" go "1:2:3:4:5:6:777:8:" go ":1:2:3:4:5:6:7777:8" @@ -284,17 +491,25 @@ -- 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 =- Left ()- @=? bimap (\_ -> ()) HexIPv6- (AT.parseOnly- (IPv6.parser <* AT.endOfInput)- (Text.pack str)) -testIPv6Encode :: Assertion-testIPv6Encode = do+expectIPv6ParserFailure :: String -> Assertion+expectIPv6ParserFailure str =+ Left ()+ @=? bimap+ (\_ -> ())+ HexIPv6+ ( AT.parseOnly+ (IPv6.parser <* AT.endOfInput)+ (Text.pack str)+ ) +expectIPv6BytesParserFailure :: String -> Assertion+expectIPv6BytesParserFailure s =+ Nothing+ @=? IPv6.decodeUtf8Bytes (Ascii.fromString s)++testIPv6Encode :: (IPv6 -> Text.Text) -> Assertion+testIPv6Encode enc = do -- degenerate cases: "::" `roundTripsTo` "::" "1234::" `roundTripsTo` "1234::"@@ -304,7 +519,7 @@ "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"+ "1234:0000:1234:0000:1234:0000:0123:1234" `roundTripsTo` "1234:0:1234:0:1234:0:123:1234" -- picks longest case: "1234:0000:1234:0000:0:0000:0123:1234" `roundTripsTo` "1234:0:1234::123:1234"@@ -319,8 +534,8 @@ "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::"+ "::2:3:4:5:6:7:8" `roundTripsTo` "0:2:3:4:5:6:7:8"+ "1:2:3:4:5:6:7::" `roundTripsTo` "1:2:3:4:5:6:7:0" -- decimal notation in IPv6 addresses: "1:2:3:4:5:6:0.7.0.8" `roundTripsTo` "1:2:3:4:5:6:7:8"@@ -331,11 +546,10 @@ "::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+ roundTripsTo s sExpected =+ case AT.parseOnly (IPv6.parser <* AT.endOfInput) (Text.pack s) of+ Right result -> enc result @?= Text.pack sExpected Left failMsg -> fail ("failed to parse '" ++ s ++ "': " ++ failMsg) textBadIPv4 :: [String]@@ -348,104 +562,125 @@ , "1.9.x.2" , "1.9.3" , "1.9"+ , "127.0.0.18446744073709551617" ] -testDecodeFailures :: [Test]+testDecodeFailures :: [TestTree] testDecodeFailures = flip map textBadIPv4 $ \str -> PH.testCase ("Should fail to decode [" ++ str ++ "]") $ IPv4.decode (Text.pack str) @?= Nothing testMacEncode :: Assertion-testMacEncode = Mac.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F)- @?= Text.pack "ff:00:ab:12:99:0f"+testMacEncode =+ Mac.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F)+ @?= Text.pack "ff:00:ab:12:99:0f" failure :: String -> Result-failure msg = failed- { reason = msg- , theException = Nothing- }+failure msg =+ failed+ { reason = msg+ , theException = Nothing+ } newtype HexMac = HexMac Mac deriving (Eq) instance Show HexMac where showsPrec _ (HexMac v) =- let (a,b,c,d,e,f) = Mac.toOctets v- in showHex a . showChar ':'- . showHex b . showChar ':'- . showHex c . showChar ':'- . showHex d . showChar ':'- . showHex e . showChar ':'- . showHex f-+ let (a, b, c, d, e, f) = Mac.toOctets v+ in showHex a+ . showChar ':'+ . showHex b+ . showChar ':'+ . showHex c+ . showChar ':'+ . showHex d+ . showChar ':'+ . showHex e+ . showChar ':'+ . showHex f newtype HexIPv6 = HexIPv6 IPv6 deriving (Eq) instance Show HexIPv6 where showsPrec _ (HexIPv6 v) =- let (a,b,c,d,e,f,g,h) = IPv6.toWord16s v- in showHex a . showChar ':'- . showHex b . showChar ':'- . showHex c . showChar ':'- . showHex d . showChar ':'- . showHex e . showChar ':'- . showHex f . showChar ':'- . showHex g . showChar ':'- . showHex h-+ let (a, b, c, d, e, f, g, h) = IPv6.toWord16s v+ in showHex a+ . showChar ':'+ . showHex b+ . showChar ':'+ . showHex c+ . showChar ':'+ . showHex d+ . showChar ':'+ . showHex e+ . showChar ':'+ . showHex f+ . showChar ':'+ . showHex g+ . showChar ':'+ . showHex h deriving instance Arbitrary IPv4 instance Arbitrary Word128 where arbitrary = Word128 <$> arbitrary <*> arbitrary- shrink (Word128 a b) = filter (/= Word128 a b)- [ Word128 0 0- , Word128 (div a 2) b- , Word128 a (div b 2)- ]+ shrink (Word128 a b) =+ filter+ (/= Word128 a b)+ [ Word128 0 0+ , Word128 (div a 2) b+ , Word128 a (div b 2)+ ] deriving instance Arbitrary IPv6 -- Half of the test cases generated are IPv6 mapped -- IPv4 addresses. instance Arbitrary IP where- arbitrary = oneof- [ IP.fromIPv4 <$> arbitrary- , IP.fromIPv6 <$> arbitrary- ]+ arbitrary =+ oneof+ [ IP.fromIPv4 <$> arbitrary+ , IP.fromIPv6 <$> arbitrary+ ] instance Arbitrary Mac where- arbitrary = Mac.fromOctets- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary+ arbitrary =+ Mac.fromOctets+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary -- This instance can generate masks that exceed the recommended -- length of 32. instance Arbitrary IPv4Range where- arbitrary = IPv4.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])- + 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 instance Arbitrary MacGrouping where- arbitrary = oneof- [ MacGroupingPairs <$> arbitraryMacSeparator- , MacGroupingTriples <$> arbitraryMacSeparator- , MacGroupingQuadruples <$> arbitraryMacSeparator- , pure MacGroupingNoSeparator- ]+ arbitrary =+ oneof+ [ MacGroupingPairs <$> arbitraryMacSeparator+ , MacGroupingTriples <$> arbitraryMacSeparator+ , MacGroupingQuadruples <$> arbitraryMacSeparator+ , pure MacGroupingNoSeparator+ ] arbitraryMacSeparator :: Gen Char-arbitraryMacSeparator = elements [':','-','.','_']+arbitraryMacSeparator = elements [':', '-', '.', '_'] +byteStringToBytes :: BC8.ByteString -> Bytes+byteStringToBytes = Ascii.fromString . BC8.unpack