ip 0.9.3 → 1.7.8
raw patch · 39 files changed
Files
- CHANGELOG.md +102/−0
- README.md +25/−0
- Setup.hs +0/−2
- ip.cabal +99/−88
- src/Data/ByteString/Builder/Fixed.hs +48/−40
- src/Data/Text/Builder/Common/Compat.hs +14/−0
- src/Data/Text/Builder/Common/Internal.hs +36/−36
- src/Data/Text/Builder/Fixed.hs +40/−34
- src/Data/Text/Builder/Variable.hs +54/−41
- src/Data/Word/Synthetic.hs +0/−13
- src/Data/Word/Synthetic/Word12.hs +132/−116
- src/Data/Word/Synthetic/Word48.hs +0/−252
- src/Net/IP.hs +277/−12
- src/Net/IPv4.hs +1449/−156
- src/Net/IPv4/ByteString/Char8.hs +0/−120
- src/Net/IPv4/Range.hs +0/−156
- src/Net/IPv4/Range/Text.hs +0/−42
- src/Net/IPv4/String.hs +0/−25
- src/Net/IPv4/Text.hs +0/−43
- src/Net/IPv6.hs +1080/−43
- src/Net/IPv6/Text.hs +0/−141
- src/Net/Internal.hs +0/−465
- src/Net/Mac.hs +978/−11
- src/Net/Mac/ByteString/Char8.hs +0/−254
- src/Net/Mac/Text.hs +0/−221
- src/Net/Types.hs +13/−324
- test/ArbitraryInstances.hs +0/−38
- test/Bench.hs +111/−55
- test/Doctests.hs +0/−7
- test/IPv4ByteString1.hs +40/−36
- test/IPv4DecodeText1.hs +19/−26
- test/IPv4DecodeText2.hs +19/−28
- test/IPv4Text1.hs +43/−40
- test/IPv4Text2.hs +13/−26
- test/IPv4TextVariableBuilder.hs +0/−30
- test/Naive.hs +18/−28
- test/Net/IPv4Spec.hs +99/−0
- test/Spec.hs +1/−0
- test/Test.hs +585/−200
+ 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 @@-name: ip-version: 0.9.3-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: >=1.10+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@@ -20,9 +21,7 @@ typeclasses of its own. Neither does it prefix functions with the name of the type that they work on. Instead, functions of the same name are exported by several different modules, and it is expected that end users- disambiguate by importing these modules qualified. For example,- `Data.IPv4.ByteString.Char8` and `Data.IPv4.Text` have nearly identical- export lists.+ disambiguate by importing these modules qualified. . The only module intended to be imported unqualified is `Net.Types`. The types in this package should not conflict with the types in@@ -31,108 +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.- .- * `impure-containers`: Provides a trie that can be used for looking- up which subnet an IP address belongs in.+ 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.Mac.Text- Net.Mac.ByteString.Char8+ Net.IP Net.IPv4- Net.IPv4.Range- Net.IPv4.Range.Text- Net.IPv4.String- Net.IPv4.Text- Net.IPv4.ByteString.Char8 Net.IPv6- Net.IPv6.Text- Net.IP+ Net.Mac Net.Types- Net.Internal- Data.Word.Synthetic- Data.Word.Synthetic.Word48- Data.Word.Synthetic.Word12++ other-modules:+ 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.8 && < 5- , attoparsec- , aeson >= 0.9 && < 1.3- , hashable >= 1.2 && < 1.3- , text >= 1.2 && < 1.3- , bytestring >= 0.10 && < 0.11- , vector >= 0.11 && < 0.13- , primitive- -- if impl(ghcjs)- -- build-depends: ghcjs-base >= 0.2 && < 0.3- 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- , test-framework- , test-framework-quickcheck2 , QuickCheck+ , 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:- ArbitraryInstances- Naive+ IPv4ByteString1 IPv4Text1 IPv4Text2- IPv4ByteString1- IPv4TextVariableBuilder- ghc-options: -Wall -O2- default-language: Haskell2010+ Naive -test-suite doctest- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Doctests.hs+test-suite spec+ 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- , 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- IPv4TextVariableBuilder- 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-+ location: git://github.com/byteverse/haskell-ip.git
src/Data/ByteString/Builder/Fixed.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-}+{-# 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@. -}@@ -22,40 +23,48 @@ , word12HexFixedUpper ) where -import Control.Monad.ST+#if !MIN_VERSION_base(4,11,0) import Data.Monoid-import Data.Word-import Data.Word.Synthetic (Word12)+#endif import Data.Bits+import Data.ByteString.Internal (ByteString (..))+import Data.ByteString.Short (ShortByteString) import Data.Char (ord)-import Text.Printf-import Debug.Trace-import Data.ByteString.Internal (ByteString(..))+import Data.Word+import Data.Word.Synthetic.Word12 (Word12) import Foreign-import Data.ByteString.Short (ShortByteString)-import System.IO.Unsafe-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Builder as BBuilder+import Text.Printf+ import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Lazy as LByteString 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 BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a +{-# INLINE appendBuilder #-}+appendBuilder :: Builder a -> Builder a -> Builder a+appendBuilder x y = case x of+ BuilderStatic t1@(PS _ _ len1) -> case y of+ BuilderStatic t2 -> BuilderStatic (t1 <> t2)+ BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)+ BuilderFunction t1@(PS _ _ len1) f1 -> case y of+ BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1+ BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)++instance Semigroup.Semigroup (Builder a) where+ {-# INLINE (<>) #-}+ (<>) = appendBuilder+ instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = BuilderStatic ByteString.empty {-# INLINE mappend #-}- mappend x y = case x of- BuilderStatic t1@(PS _ _ len1) -> case y of- BuilderStatic t2 -> BuilderStatic (t1 <> t2)- BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)- BuilderFunction t1@(PS _ _ len1) f1 -> case y of- BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1- BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)+ mappend = (Semigroup.<>) contramapBuilder :: (b -> a) -> Builder a -> Builder b contramapBuilder f x = case x of@@ -67,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@@ -80,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@@ -95,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@@ -117,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@@ -139,12 +152,9 @@ word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w {-# INLINE word8 #-} -word8At :: Int -> Word64 -> Word8-word8At i w = fromIntegral (unsafeShiftR w i)-{-# INLINE word8At #-}---- | 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 #-}@@ -162,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,41 +1,31 @@ module Data.Text.Builder.Common.Internal where -import Data.Text (Text) import Control.Monad.ST-import Data.Monoid-import Data.Word-import Data.Bits-import Text.Printf-import Debug.Trace import Data.Char (ord)-import Data.Word.Synthetic (Word12)-import Data.Vector (Vector) import Data.Foldable (fold)-import qualified Data.Vector as Vector+import Data.Monoid+import Data.Text (Text) import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.IO as LText-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Lazy.Builder.Int as TBuilder-import qualified Data.Text.IO as Text import qualified Data.Text.Array as A-import qualified Data.Text.Internal as TI 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@@ -43,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@@ -58,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,11 +1,11 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-}+{-# 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@. -}@@ -22,47 +22,47 @@ ) where import Control.Monad.ST+#if !MIN_VERSION_base(4,11,0) import Data.Monoid-import Data.Word+#endif import Data.Bits-import Text.Printf-import Debug.Trace import Data.Char (ord)-import Data.Word.Synthetic (Word12)-import Data.Vector (Vector)-import Data.Foldable (fold)+import qualified Data.Semigroup as Semigroup import Data.Text (Text)-import qualified Data.Vector as Vector import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.IO as LText-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Lazy.Builder.Int as TBuilder-import qualified Data.Text.IO as Text import qualified Data.Text.Array as A-import qualified Data.Text.Internal as TI-import qualified Data.Text.Internal.Unsafe.Char as TC 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 BuilderFunction :: Text -> (forall s. Int -> A.MArray s -> a -> ST s ()) -> Builder a +{-# INLINE appendBuilder #-}+appendBuilder :: Builder a -> Builder a -> Builder a+appendBuilder x y = case x of+ BuilderStatic t1 -> case y of+ BuilderStatic t2 -> BuilderStatic (t1 <> t2)+ BuilderFunction t2 f ->+ let len1 = I.portableTextLength t1+ in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)+ BuilderFunction t1 f1 -> case y of+ BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1+ BuilderFunction t2 f2 ->+ let len1 = I.portableTextLength t1+ in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)++instance Semigroup.Semigroup (Builder a) where+ {-# INLINE (<>) #-}+ (<>) = appendBuilder+ instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = BuilderStatic Text.empty {-# INLINE mappend #-}- mappend x y = case x of- BuilderStatic t1 -> case y of- BuilderStatic t2 -> BuilderStatic (t1 <> t2)- BuilderFunction t2 f ->- let len1 = I.portableTextLength t1- in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)- BuilderFunction t1 f1 -> case y of- BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1- BuilderFunction t2 f2 ->- let len1 = I.portableTextLength t1- in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)+ mappend = (Semigroup.<>) fromText :: Text -> Builder a fromText = BuilderStatic@@ -74,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@@ -82,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@@ -107,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))@@ -133,4 +140,3 @@ word12HexFixedLower :: Builder Word12 word12HexFixedLower = word12HexFixedGeneral False {-# INLINE word12HexFixedLower #-}-
src/Data/Text/Builder/Variable.hs view
@@ -1,14 +1,15 @@-{-# 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, data whose textual encoding has no known upper bound cannot be encoded by the builder provided here. For example, it- is possible to provide decimal builders for types like 'Int8' and+ is possible to provide decimal builders for types like 'Data.Int.Int8' and 'Word16', whose lengths are respectively bounded by 4 and 5. However, this is not possible for 'Integer', since its decimal representation could be arbitrarily long.@@ -22,41 +23,47 @@ , word8 ) where -import Data.Monoid-import Data.Word-import Data.Text (Text)-import Text.Printf (printf) import Control.Monad.ST import Data.Char (ord)-import Data.Vector (Vector)-import Data.Function (on) import Data.Maybe (fromMaybe)-import qualified Data.Vector as Vector-import qualified Data.Text as Text+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 {-# UNPACK #-} !Int -- the maximum length, not a character count !(forall s. Int -> A.MArray s -> a -> ST s Int) +{-# INLINE appendBuilder #-}+appendBuilder :: Builder a -> Builder a -> Builder a+appendBuilder (Builder len1 f) (Builder len2 g) =+ Builder (len1 + len2) $ \ix1 marr a -> do+ ix2 <- f ix1 marr a+ g ix2 marr a++instance Semigroup.Semigroup (Builder a) where+ {-# INLINE (<>) #-}+ (<>) = appendBuilder+ instance Monoid (Builder a) where {-# INLINE mempty #-} mempty = Builder 0 (\i _ _ -> return i) {-# INLINE mappend #-}- mappend (Builder len1 f) (Builder len2 g) =- Builder (len1 + len2) $ \ix1 marr a -> do- ix2 <- f ix1 marr a- g ix2 marr a+ mappend = (Semigroup.<>) run :: Builder a -> a -> Text run (Builder maxLen f) = \a ->- 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 #-} @@ -83,47 +90,53 @@ {-# 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 ::+_vector :: Text -- ^ Default, used when index is out of range -> Vector Text -- ^ Texts to index into -> Builder Int-vector tDef v =+_vector tDef v = let xs = Vector.map I.portableUntext v xDef = I.portableUntext tDef in Builder (Vector.maximum $ Vector.map I.portableTextLength $ Vector.cons tDef v)- $ \pos marr i -> do+ $ \_ 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 #-}+{-# 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.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Word.Synthetic- ( Word48- , Word12- ) where--import Data.Word.Synthetic.Word48 (Word48)-import Data.Word.Synthetic.Word12 (Word12)-
src/Data/Word/Synthetic/Word12.hs view
@@ -1,53 +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 Foreign.Storable+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.Ptr-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@@ -56,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.@@ -66,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#) @@ -87,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/Data/Word/Synthetic/Word48.hs
@@ -1,252 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Word.Synthetic.Word48 where--import Data.Bits-import Data.Word-import Data.Int-import Data.Ratio-import GHC.Arr-import GHC.Enum-import Data.Primitive.Types-import Data.Hashable (Hashable)-import qualified Data.Vector.Unboxed as UVector-import qualified Data.Vector.Generic as GVector-import qualified Data.Vector.Unboxed.Mutable as MUVector-import qualified Data.Vector.Generic.Mutable as MGVector--newtype Word48 = W48 Word64- deriving (Eq,Ord,Hashable)--narrow48Word :: Word64 -> Word64-narrow48Word = (.&.) 0xFFFFFFFFFFFF-{-# INLINE narrow48Word #-}--popCnt48 :: Word64 -> Int-popCnt48 = popCount . narrow48Word-{-# INLINE popCnt48 #-}--word48UpperWord16 :: Word48 -> Word16-word48UpperWord16 (W48 w) = fromIntegral (unsafeShiftR w 32)--word48LowerWord32 :: Word48 -> Word32-word48LowerWord32 (W48 w) = fromIntegral w--word48FromUpperLower :: Word16 -> Word32 -> Word48-word48FromUpperLower a b =- W48 (unsafeShiftL (fromIntegral a) 32 .|. fromIntegral b)--instance Show Word48 where- showsPrec p (W48 x) = showsPrec p x--instance Num Word48 where- (W48 x) + (W48 y) = W48 (narrow48Word (x + y))- (W48 x) - (W48 y) = W48 (narrow48Word (x - y))- (W48 x) * (W48 y) = W48 (narrow48Word (x * y))- negate (W48 x) = W48 (negate (fromIntegral (negate (fromIntegral x :: Int64))))- abs x = x- signum 0 = 0- signum _ = 1- fromInteger i = W48 (narrow48Word (fromInteger i))--instance Real Word48 where- toRational (W48 x) = toInteger x % 1--instance Enum Word48 where- succ x- | x /= maxBound = x + 1- | otherwise = succError "Word48"- pred x- | x /= minBound = x - 1- | otherwise = predError "Word48"- toEnum i- | i >= 0 && i <= fromIntegral (maxBound :: Word48)- = W48 (fromIntegral i)- | otherwise = toEnumError "Word48" i (minBound::Word48, maxBound::Word48)- -- Causes a bounds check to occur twice- fromEnum (W48 x)- | x <= fromIntegral (maxBound :: Int) = fromIntegral x- | otherwise = fromEnumError "Word48" x- enumFrom = boundedEnumFrom- enumFromThen = boundedEnumFromThen--instance Integral Word48 where- quot (W48 x) (W48 y) = W48 (x `quot` y)- rem (W48 x) (W48 y) = W48 (x `rem` y)- div (W48 x) (W48 y) = W48 (x `quot` y)- mod (W48 x) (W48 y) = W48 (x `rem` y)- quotRem (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y))- divMod (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y))- toInteger (W48 x) = toInteger x--instance Bounded Word48 where- minBound = 0- maxBound = 0xFFFFFFFFFFFF--instance Ix Word48 where- range (m,n) = [m..n]- unsafeIndex (m,_) i = fromIntegral (i - m)- inRange (m,n) i = m <= i && i <= n--instance Read Word48 where- readsPrec p s = [(fromIntegral (x::Word64), r) | (x, r) <- readsPrec p s]--instance Bits Word48 where- {-# INLINE shift #-}- {-# INLINE bit #-}- {-# INLINE testBit #-}-- (W48 x) .&. (W48 y) = W48 (x .&. y)- (W48 x) .|. (W48 y) = W48 (x .|. y)- (W48 x) `xor` (W48 y) = W48 (x `xor` y)- complement (W48 x) = W48 (x `xor` mb) where !(W48 mb) = maxBound- (W48 x) `shift` i- | i >= 0 = W48 (narrow48Word (x `shiftL` i))- | otherwise = W48 (x `shiftR` negate i)- (W48 x) `shiftL` i = W48 (narrow48Word (x `shiftL` i))- (W48 x) `unsafeShiftL` i =- W48 (narrow48Word (x `unsafeShiftL` i))- (W48 x) `shiftR` i = W48 (x `shiftR` i)- (W48 x) `unsafeShiftR` i = W48 (x `unsafeShiftR` i)- (W48 x) `rotate` i- | i' == 0 = W48 x- | otherwise = W48 (narrow48Word ((x `unsafeShiftL` i') .|.- (x `unsafeShiftR` (48 - i'))))- where- !i' = i `mod` 48- bitSizeMaybe i = Just (finiteBitSize i)- bitSize = finiteBitSize- isSigned _ = False- popCount (W48 x) = popCnt48 x- bit = bitDefault- testBit = testBitDefault--instance FiniteBits Word48 where- finiteBitSize _ = 48- countLeadingZeros (W48 x) = countLeadingZeros x - 16- countTrailingZeros (W48 x) = countTrailingZeros x--data instance MUVector.MVector s Word48- = MV_Word48- {-# UNPACK #-} !Int- !(MUVector.MVector s Word16)- !(MUVector.MVector s Word32)--data instance UVector.Vector Word48- = V_Word48- {-# UNPACK #-} !Int- !(UVector.Vector Word16)- !(UVector.Vector Word32)--instance UVector.Unbox Word48--instance MGVector.MVector MUVector.MVector Word48 where- {-# INLINE basicLength #-}- basicLength (MV_Word48 n_ as bs) = n_- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (MV_Word48 n_ as bs)- = MV_Word48 m_- (MGVector.basicUnsafeSlice i_ m_ as)- (MGVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicOverlaps #-}- basicOverlaps (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 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_Word48 n_ as bs- {-# INLINE basicInitialize #-}- basicInitialize (MV_Word48 _ as bs)- = do- MGVector.basicInitialize as- MGVector.basicInitialize bs- {-# INLINE basicUnsafeReplicate #-}- basicUnsafeReplicate n_ w- = do- let upper = word48UpperWord16 w- lower = word48LowerWord32 w- as <- MGVector.basicUnsafeReplicate n_ upper- bs <- MGVector.basicUnsafeReplicate n_ lower- return $ MV_Word48 n_ as bs- {-# INLINE basicUnsafeRead #-}- basicUnsafeRead (MV_Word48 n_ as bs) i_- = do- a <- MGVector.basicUnsafeRead as i_- b <- MGVector.basicUnsafeRead bs i_- return (word48FromUpperLower a b)- {-# INLINE basicUnsafeWrite #-}- basicUnsafeWrite (MV_Word48 n_ as bs) i_ w- = do- let upper = word48UpperWord16 w- lower = word48LowerWord32 w- MGVector.basicUnsafeWrite as i_ upper- MGVector.basicUnsafeWrite bs i_ lower- {-# INLINE basicClear #-}- basicClear (MV_Word48 n_ as bs)- = do- MGVector.basicClear as- MGVector.basicClear bs- {-# INLINE basicSet #-}- basicSet (MV_Word48 n_ as bs) w- = do- let upper = word48UpperWord16 w- lower = word48LowerWord32 w- MGVector.basicSet as upper- MGVector.basicSet bs lower- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2)- = do- MGVector.basicUnsafeCopy as1 as2- MGVector.basicUnsafeCopy bs1 bs2- {-# INLINE basicUnsafeMove #-}- basicUnsafeMove (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2)- = do- MGVector.basicUnsafeMove as1 as2- MGVector.basicUnsafeMove bs1 bs2- {-# INLINE basicUnsafeGrow #-}- basicUnsafeGrow (MV_Word48 n_ as bs) m_- = do- as' <- MGVector.basicUnsafeGrow as m_- bs' <- MGVector.basicUnsafeGrow bs m_- return $ MV_Word48 (m_+n_) as' bs'--instance GVector.Vector UVector.Vector Word48 where- {-# INLINE basicUnsafeFreeze #-}- basicUnsafeFreeze (MV_Word48 n_ as bs)- = do- as' <- GVector.basicUnsafeFreeze as- bs' <- GVector.basicUnsafeFreeze bs- return $ V_Word48 n_ as' bs'- {-# INLINE basicUnsafeThaw #-}- basicUnsafeThaw (V_Word48 n_ as bs)- = do- as' <- GVector.basicUnsafeThaw as- bs' <- GVector.basicUnsafeThaw bs- return $ MV_Word48 n_ as' bs'- {-# INLINE basicLength #-}- basicLength (V_Word48 n_ as bs) = n_- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (V_Word48 n_ as bs)- = V_Word48 m_ (GVector.basicUnsafeSlice i_ m_ as)- (GVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicUnsafeIndexM #-}- basicUnsafeIndexM (V_Word48 n_ as bs) i_- = do- a <- GVector.basicUnsafeIndexM as i_- b <- GVector.basicUnsafeIndexM bs i_- return (word48FromUpperLower a b)- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (V_Word48 n_2 as2 bs2)- = do- GVector.basicUnsafeCopy as1 as2- GVector.basicUnsafeCopy bs1 bs2- {-# INLINE elemseq #-}- elemseq _ = seq--
src/Net/IP.hs view
@@ -1,19 +1,284 @@-module Net.IP where+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall #-} -import Net.Types+{- | 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'+ addresses being represented as an IPv4-mapped IPv6 addresses:++ > +---------+---------+--------------++ > | 80 bits | 16 bits | 32 bits |+ > +---------+---------+--------------++ > | 00...00 | FFFF | IPv4 address |+ > +---------+---------+--------------+++ All functions and instance methods that deal with textual conversion+ will encode an 'IP' using either dot-decimal notation (for IPv4) or+ RFC 5952 (for IPv6). They will decode an 'IP' from either format+ as well. The 'Show' instance presents an address in as valid haskell code+ that resembles the formatted address:++ >>> decode "192.168.3.100"+ Just (ipv4 192 168 3 100)+ >>> 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 (..)+ ) where++import Control.DeepSeq (NFData)+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.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 Text.ParserCombinators.ReadPrec ((+++))+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+>>> 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"+-} case_ :: (IPv4 -> a) -> (IPv6 -> a) -> IP -> a-case_ f g (IP addr@(IPv6 w1 w2)) = if w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000)- then f (IPv4 (fromIntegral w2))- else g addr+-- 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 --- | If the address is an 'IPv4' address, return the address.-ipv4 :: IP -> Maybe IPv4-ipv4 = case_ Just (const Nothing)+{- | 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) --- | If the address is an 'IPv6' address, and if it is not--- an IPv4-mapped IPv6 address, return the address.-ipv6 :: IP -> Maybe IPv6-ipv6 = case_ (const Nothing) Just+{- | 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'.+fromIPv4 :: IPv4 -> IP+fromIPv4 (IPv4 w) = IP (IPv6 (Word128 0 (0x0000FFFF00000000 .|. fromIntegral w)))++-- | Turn an 'IPv6' into an 'IP'.+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 :: IP -> Text+encode = case_ IPv4.encode IPv6.encode++{- | 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+ Nothing -> Nothing+ Just v6 -> Just (fromIPv6 v6)+ Just v4 -> Just (fromIPv4 v4)++{- | 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 #-}++{- | 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 #-}++{- | 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 stock (Eq, Ord, Generic, Ix, Data)+ deriving newtype (Hashable)++instance NFData IP++instance Show IP where+ showsPrec p = case_ (showsPrec p) (showsPrec p)++instance Read IP where+ readPrec = fmap fromIPv4 readPrec +++ fmap fromIPv6 readPrec++instance ToJSON IP where+ toJSON = Aeson.String . encode++instance FromJSON IP where+ 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,156 +1,1449 @@-{-| An IPv4 data type-- This module provides the IPv4 data type and functions for working- with it. There are also encoding and decoding functions provided- in this module, but they should be imported from- @Net.IPv4.Text@ and @Net.IPv4.ByteString.Char8@ instead. They are- defined here so that the 'FromJSON' and 'ToJSON' instances can- use them.-- At some point, a highly efficient IPv4-to-ByteString function needs- to be added to this module to take advantage of @aeson@'s new- @toEncoding@ method.--}--module Net.IPv4- ( -- * Conversion Functions- fromOctets- , toOctets- -- * Special IP Addresses- , any- , loopback- , broadcast- -- * Range Predicates- , private- , reserved- , public- ) where--import Prelude hiding (any)-import Net.Types (IPv4(..))-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Word-import Data.Int-import Data.Hashable-import Data.Aeson (FromJSON(..),ToJSON(..))-import GHC.Generics (Generic)-import Net.Internal (attoparsecParseJSON,rightToMaybe)-import Control.Monad-import Data.Text.Internal (Text(..))-import Data.Coerce (coerce)-import Unsafe.Coerce (unsafeCoerce)-import Data.ByteString (ByteString)-import Data.Vector.Generic.Mutable (MVector(..))-import Control.Monad.Primitive (PrimMonad,PrimState)-import qualified Net.Internal as Internal-import qualified Data.Text.Lazy as LText-import qualified Data.Text.IO as Text-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString---- $setup------ These are here to get doctest's property checking to work------ >>> import Test.QuickCheck (Arbitrary(..))--- >>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }------- | Create an 'IPv4' address from four octets. The first argument--- is the most significant octet. The last argument is the least--- significant.------ Since the 'Show' and 'Read' instances for 'IPv4' are not generally--- usefully, this function is the recommened way to create 'IPv4' addresses.--- For example:------ >>> fromOctets 192 168 1 1--- IPv4 {getIPv4 = 3232235777}----fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> IPv4-fromOctets a b c d = IPv4 $ Internal.fromOctets'- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral 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: @0.0.0.0@-any :: IPv4-any = IPv4 0---- | The loopback IP address: @127.0.0.1@-loopback :: IPv4-loopback = fromOctets 127 0 0 1---- | The broadcast IP address: @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) =- Internal.mask8 .&. w == Internal.p24- || Internal.mask12 .&. w == Internal.p20- || Internal.mask16 .&. w == Internal.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 = Internal.fromOctets' 0 0 0 0- b = Internal.fromOctets' 100 64 0 0- c = Internal.fromOctets' 127 0 0 0- d = Internal.fromOctets' 169 254 0 0- e = Internal.fromOctets' 192 0 0 0- f = Internal.fromOctets' 192 0 2 0- g = Internal.fromOctets' 192 88 99 0- h = Internal.fromOctets' 198 18 0 0- i = Internal.fromOctets' 198 51 100 0- j = Internal.fromOctets' 203 0 113 0- k = Internal.fromOctets' 224 0 0 0- l = Internal.fromOctets' 240 0 0 0- m = Internal.fromOctets' 255 255 255 255- in \(IPv4 w) -> Internal.mask8 .&. w == Internal.p24- || Internal.mask12 .&. w == Internal.p20- || Internal.mask16 .&. w == Internal.p16- || Internal.mask8 .&. w == a- || Internal.mask10 .&. w == b- || Internal.mask16 .&. w == d- || Internal.mask24 .&. w == e- || Internal.mask24 .&. w == g- || Internal.mask15 .&. w == h- || Internal.mask24 .&. w == i- || Internal.mask24 .&. w == j- || Internal.mask4 .&. w == k- || Internal.mask4 .&. w == l- || Internal.mask32 .&. w == m---- | Checks to see if the 'IPv4' address is publicly routable.------ prop> public x == not (reserved x)-public :: IPv4 -> Bool-public = not . reserved---- | $internal--- Everything below here is not part of the stable API. Many of these--- functions must live here because they are needed for the 'ToJSON' and--- 'FromJSON' instances. Hopefully, at some point, these can be removed--- from this module.---- This only exists for doctests. Do not use it.--- prAddr :: IPv4 -> IO ()--- prAddr (IPv4 addr) = Text.putStrLn (Internal.toDotDecimalText addr)--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# 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/IPv4/ByteString/Char8.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Net.IPv4.ByteString.Char8- ( encode- , decode- , builder- , parser- ) where--import Net.Types (IPv4(..))-import Net.IPv4-import Control.Monad-import Data.Coerce (coerce)-import qualified Net.Internal as Internal-import qualified Net.IPv4.Text as IPv4Text-import qualified Data.Attoparsec.ByteString.Char8 as AB-import qualified Data.ByteString.Builder as Builder-import Net.Internal (rightToMaybe)-import Data.Text.Encoding (encodeUtf8, decodeUtf8')-import Data.ByteString (ByteString,replicate)-import Data.Attoparsec.ByteString.Char8 (Parser)-import Data.ByteString.Builder (Builder)-import Data.ByteString.Char8 as BC8--import Data.ByteString.Internal as I-import Data.Bits-import Foreign.Ptr-import Foreign.Storable-import Data.Word-import Data.ByteString.Unsafe as BSU-import Data.Monoid---- | This should be rewritten to not create 'Text' as an--- intermediate step.-encode :: IPv4 -> ByteString-encode = 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 . BSU.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 . BSU.unsafeIndex twoDigits- poke ptr (get2 indx)- poke (ptr `plusPtr` 1) (get2 (indx + 1))- return 2- | otherwise = do- poke ptr (word + 48)- return 1--twoDigits :: ByteString-twoDigits = BC8.pack- "0001020304050607080910111213141516171819\- \2021222324252627282930313233343536373839\- \4041424344454647484950515253545556575859\- \6061626364656667686970717273747576777879\- \8081828384858687888990919293949596979899"--threeDigits :: ByteString-threeDigits =- Data.ByteString.replicate 300 0 <> BC8.pack- "100101102103104105106107108109110111112\- \113114115116117118119120121122123124125\- \126127128129130131132133134135136137138\- \139140141142143144145146147148149150151\- \152153154155156157158159160161162163164\- \165166167168169170171172173174175176177\- \178179180181182183184185186187188189190\- \191192193194195196197198199200201202203\- \204205206207208209210211212213214215216\- \217218219220221222223224225226227228229\- \230231232233234235236237238239240241242\- \243244245246247248249250251252253254255"---- | This should also be rewritten-decode :: ByteString -> Maybe IPv4-decode = IPv4Text.decode <=< rightToMaybe . decodeUtf8'--builder :: IPv4 -> Builder-builder = Builder.byteString . encode--parser :: Parser IPv4-parser = coerce $ Internal.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 ip address must be between 0 and 255"- else return i
− src/Net/IPv4/Range.hs
@@ -1,156 +0,0 @@-module Net.IPv4.Range- ( -- * Range functions- normalize- , contains- , member- , lowerInclusive- , upperInclusive- -- * Conversion to IPv4- , toList- , toGenerator- -- * Private Ranges- , private24- , private20- , private16- -- * Internal Functions- -- $internal- , prRange- ) where--import Net.Types (IPv4(..),IPv4Range(..))-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Coerce (coerce)-import Control.Monad-import qualified Net.Internal as Internal-import qualified Net.IPv4 as IPv4-import qualified Data.Text.IO as Text---- $setup------ These are here to get doctest's property checking to work.------ >>> import qualified Net.IPv4.Text as I--- >>> import Net.IPv4 (fromOctets)--- >>> import Test.QuickCheck (Arbitrary(..))--- >>> instance Arbitrary IPv4 where { arbitrary = fmap IPv4 arbitrary }--- >>> instance Arbitrary IPv4Range where { arbitrary = IPv4Range <$> arbitrary <*> arbitrary }------- | 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_ (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 = Internal.mask len- wsubnetNormalized = wsubnet .&. theMask- in \(IPv4 w) -> (w .&. theMask) == wsubnetNormalized---- | 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:------ >>> I.print $ lowerInclusive $ IPv4Range (fromOctets 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 .&. Internal.mask len)--upperInclusive :: IPv4Range -> IPv4-upperInclusive (IPv4Range (IPv4 w) len) =- let theInvertedMask = shiftR 0xffffffff (fromIntegral len)- theMask = complement theInvertedMask- in IPv4 ((w .&. theMask) .|. theInvertedMask)---- | Convert an 'IPv4Range' into a list of the 'IPv4' addresses that--- are in it.--- >>> let r = IPv4Range (fromOctets 192 168 1 8) 30--- >>> mapM_ I.print (toList r)--- 192.168.1.8--- 192.168.1.9--- 192.168.1.10--- 192.168.1.11--toList :: IPv4Range -> [IPv4]-toList (IPv4Range (IPv4 ip) len) = - let totalAddrs = Internal.countAddrs len- in coerce (Internal.wordSuccessors totalAddrs ip)--toGenerator :: MonadPlus m => IPv4Range -> m IPv4-toGenerator (IPv4Range (IPv4 ip) len) = - let totalAddrs = Internal.countAddrs len- in Internal.wordSuccessorsM IPv4 totalAddrs ip---- | The RFC1918 24-bit block. Subnet mask: @10.0.0.0/8@-private24 :: IPv4Range-private24 = IPv4Range (IPv4 Internal.p24) 8---- | The RFC1918 20-bit block. Subnet mask: @172.16.0.0/12@-private20 :: IPv4Range-private20 = IPv4Range (IPv4 Internal.p20) 12---- | The RFC1918 16-bit block. Subnet mask: @192.168.0.0/16@-private16 :: IPv4Range-private16 = IPv4Range (IPv4 Internal.p16) 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:------ >>> prRange $ normalize $ IPv4Range (fromOctets 192 168 1 19) 24--- 192.168.1.0/24--- >>> prRange $ 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 .&. Internal.mask len'- in IPv4Range (IPv4 w') len'----- | This only exists for doctests. Do not use it.-prRange :: IPv4Range -> IO ()-prRange (IPv4Range (IPv4 addr) range) =- Text.putStrLn (Internal.rangeToDotDecimalText addr range)-
− src/Net/IPv4/Range/Text.hs
@@ -1,42 +0,0 @@-module Net.IPv4.Range.Text- ( encode- , decode- , decodeEither- , builder- , parser- , print- ) where--import Prelude hiding (print)-import Net.Types (IPv4Range(..),IPv4(..))-import Data.Text (Text)-import Data.Word (Word8, Word32)-import qualified Data.Text.IO as Text-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Net.Internal as Internal--encode :: IPv4Range -> Text-encode (IPv4Range (IPv4 w) r) = Internal.rangeToDotDecimalText w r--decodeEither :: Text -> Either String IPv4Range-decodeEither = Internal.rangeFromDotDecimalText' mkIPv4Range--decode :: Text -> Maybe IPv4Range-decode = Internal.rightToMaybe . decodeEither--builder :: IPv4Range -> TBuilder.Builder-builder (IPv4Range (IPv4 w) r) = Internal.rangeToDotDecimalBuilder w r--parser :: AT.Parser IPv4Range-parser = Internal.dotDecimalRangeParser mkIPv4Range---- | This exists mostly for testing purposes.-print :: IPv4Range -> IO ()-print = Text.putStrLn . encode---- internal function-mkIPv4Range :: Word32 -> Word8 -> IPv4Range-mkIPv4Range w = IPv4Range (IPv4 w)-{-# INLINE mkIPv4Range #-}-
− src/Net/IPv4/String.hs
@@ -1,25 +0,0 @@--- | This module exists for the convenience of those who need a--- 'String' representation of an 'IPv4' address. Using this module--- 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@).----module Net.IPv4.String- ( encode- , decode- , decodeEither- ) where--import Net.Types (IPv4(..))-import qualified Data.Text as Text-import qualified Net.IPv4.Text as N--encode :: IPv4 -> String-encode = Text.unpack . N.encode--decode :: String -> Maybe IPv4-decode = N.decode . Text.pack--decodeEither :: String -> Either String IPv4-decodeEither = N.decodeEither . Text.pack-
− src/Net/IPv4/Text.hs
@@ -1,43 +0,0 @@-module Net.IPv4.Text- ( encode- , decode- , decodeEither- , builder- , reader- , parser- , print- ) where--import Prelude hiding (print)-import Net.Types (IPv4(..))-import Net.IPv4-import Data.Text (Text)-import Data.Coerce (coerce)-import qualified Data.Text.Read as Text (Reader)-import qualified Data.Text.IO as Text-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Net.Internal as Internal--encode :: IPv4 -> Text-encode = Internal.toDotDecimalText . getIPv4--decodeEither :: Text -> Either String IPv4-decodeEither = coerce . Internal.decodeIPv4TextEither--decode :: Text -> Maybe IPv4-decode = Internal.rightToMaybe . decodeEither--builder :: IPv4 -> TBuilder.Builder-builder = Internal.toDotDecimalBuilder . getIPv4--reader :: Text.Reader IPv4-reader = coerce Internal.decodeIPv4TextReader--parser :: AT.Parser IPv4-parser = coerce Internal.dotDecimalParser---- | This exists mostly for testing purposes.-print :: IPv4 -> IO ()-print = Text.putStrLn . encode-
src/Net/IPv6.hs view
@@ -1,44 +1,1081 @@ {-# LANGUAGE BangPatterns #-}--module Net.IPv6 where--import qualified Net.Internal as Internal-import Data.Bits-import Data.Word-import Net.Types--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 =- let !(w1,w2) = Internal.fromOctetsV6- (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)- in IPv6 w1 w2--fromWord16s ::- Word16 -> Word16 -> Word16 -> Word16- -> Word16 -> Word16 -> Word16 -> Word16- -> IPv6-fromWord16s a b c d e f g h =- let !(w1,w2) = Internal.fromWord16sV6- (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)- (fromIntegral e) (fromIntegral f) (fromIntegral g) (fromIntegral h)- in IPv6 w1 w2--toWord16s :: IPv6 -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16)-toWord16s (IPv6 a b) =- ( 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- )+{-# 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))++maskFromBounds :: IPv6 -> IPv6 -> Word8+maskFromBounds lo hi = fromIntegral (countLeadingZeros $ xor lo hi)
− src/Net/IPv6/Text.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Net.IPv6.Text- ( encode- , parser- ) where--import Prelude hiding (print)-import Net.Types (IPv6(..))-import Net.IPv6 (toWord16s)-import Data.Bits-import Data.List (intercalate, group)-import Data.Word-import Control.Applicative-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Attoparsec.Text as Atto-import Numeric (showHex)---- | Encodes the IP, using zero-compression on the leftmost-longest string of--- zeroes in the address.-encode :: IPv6 -> Text-encode ip = 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 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)-- -parser :: Atto.Parser IPv6-parser = do- s <- start- case toIPv6 s of- Nothing -> fail "Wrong number of octets in IPv6 address"- Just ip -> return ip- where- msg = "All chunks in a formatted IPv6 address must be between 0x0000 and 0xFFFF"- colonMsg = "Cannot use double colon for omitting zeroes more than once in an IPv6 address"- start = do- c <- Atto.peekChar'- if c == ':'- then go (-1) 0 []- else Atto.hexadecimal >>= \w -> go (-1) 1 [w]- -- r <- fmap Just Atto.hexadecimal <|> (Nothing <$ Atto.char ':')- -- case r of- -- Just !w -> go (-1) 1 [w]- -- Nothing -> go 0 0 []- go !colonIndex !currentIndex !ws = do- r <- do- m <- Atto.peekChar- case m of- Nothing -> return ResDone- Just c -> if c == ':'- then do- _ <- Atto.anyChar -- should be a colon- if colonIndex == currentIndex- then fmap ResWord Atto.hexadecimal <|> pure ResDone- else do- d <- Atto.peekChar'- if d == ':'- then return ResColon- else fmap ResWord Atto.hexadecimal- else return ResDone- case r of- ResDone -> pure (S colonIndex currentIndex ws)- ResColon -> if alreadySet colonIndex- then fail colonMsg- else go currentIndex currentIndex ws- ResWord w -> restrictTo16 msg w >> go colonIndex (currentIndex + 1) (w : ws)--toIPv6 :: S -> Maybe IPv6-toIPv6 (S colonIndex total input) = case compare total 8 of- EQ -> if colonIndex == (-1)- then go 0 0 input- else Nothing- GT -> Nothing- LT -> go 0 0 input- where- revColonIndex = total - colonIndex- spacesToSkip = 8 - total- go :: Int -> Word64 -> [Word64] -> Maybe IPv6- go !ix !acc ws = if ix > 3- then fmap (flip IPv6 acc) (go2 ix 0 ws)- else case ws of- w : wsNext -> if ix == revColonIndex- then go (ix + spacesToSkip) acc (w : wsNext)- else go (ix + 1) (acc .|. unsafeShiftL w (times16 ix)) wsNext- [] -> if ix == revColonIndex- then Just $ IPv6 0 acc- else Nothing -- Not enough word16s in list- go2 :: Int -> Word64 -> [Word64] -> Maybe Word64- go2 !ix !acc ws = case ws of- w : wsNext -> if ix == revColonIndex- then go2 (ix + spacesToSkip) acc (w : wsNext)- else go2 (ix + 1) (acc .|. unsafeShiftL w (times16 ix - 64)) wsNext- [] -> if ix == revColonIndex || ix > 7- then Just acc- else Nothing -- Not enough word16s in list--times16 :: Int -> Int-times16 a = unsafeShiftL a 4--alreadySet :: Int -> Bool-alreadySet i = i /= (-1)--restrictTo16 :: String -> Word64 -> Atto.Parser ()-restrictTo16 msg w = if w > 65535- then fail msg- else return ()---- | This is an internal data type used as the result--- after parsing an ipv6 address. The first field--- indicates the index at which a double colon occurs.--- The second is the length of the third.--- The third is a reversed list of the 16s--- that comprise the ipv6 address.-data S = S- { _sDoubleColon :: {-# UNPACK #-} !Int- , _sTotal :: {-# UNPACK #-} !Int- , _sRevWords :: ![Word64]- } deriving (Show,Read)--data Res- = ResWord {-# UNPACK #-} !Word64- | ResColon- | ResDone--
− src/Net/Internal.hs
@@ -1,465 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--module Net.Internal where--import Data.Monoid ((<>))-import Data.Word-import Data.Bits ((.&.),(.|.),shiftR,shiftL,shift,complement,unsafeShiftR,unsafeShiftL)-import Control.Monad.ST-import Data.Text.Internal (Text(..))-import Data.ByteString (ByteString)-import Data.Text.Lazy.Builder.Int (decimal)-import Control.Monad-import Text.Printf (printf)-import Data.Char (chr,ord)-import Data.Word.Synthetic (Word48)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Attoparsec.Text as AT-import qualified Data.Aeson.Types as Aeson-import qualified Data.Text.Array as TArray-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Read as TextRead-import qualified Data.Text.Lazy.Builder.Int as TBuilder---- | Taken from @Data.ByteString.Internal@. The same warnings--- apply here.-c2w :: Char -> Word8-c2w = fromIntegral . ord-{-# INLINE c2w #-}--eitherToAesonParser :: Either String a -> Aeson.Parser a-eitherToAesonParser x = case x of- Left err -> fail err- Right a -> return a--attoparsecParseJSON :: AT.Parser a -> Aeson.Value -> Aeson.Parser a-attoparsecParseJSON p v =- case v of- Aeson.String t ->- case AT.parseOnly p t of- Left err -> fail err- Right res -> return res- _ -> fail "expected a String"--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"-{-# INLINE stripDecimal #-}--decodeIPv4TextReader :: TextRead.Reader Word32-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)-{-# INLINE decodeIPv4TextReader #-}--decodeIPv4TextEither :: Text -> Either String Word32-decodeIPv4TextEither t = case decodeIPv4TextReader t of- Left err -> Left err- Right (w,t') -> if Text.null t'- then Right w- else Left "expected end of text but it continued instead"--ipOctetSizeErrorMsg :: String-ipOctetSizeErrorMsg = "All octets in an IPv4 address must be between 0 and 255"--rightToMaybe :: Either a b -> Maybe b-rightToMaybe = either (const Nothing) Just--toDotDecimalText :: Word32 -> Text-toDotDecimalText = toTextPreAllocated-{-# INLINE toDotDecimalText #-}--toDotDecimalBuilder :: Word32 -> TBuilder.Builder-toDotDecimalBuilder = TBuilder.fromText . toTextPreAllocated-{-# INLINE toDotDecimalBuilder #-}--rangeToDotDecimalText :: Word32 -> Word8 -> Text-rangeToDotDecimalText addr len =- LText.toStrict (TBuilder.toLazyText (rangeToDotDecimalBuilder addr len))--rangeToDotDecimalBuilder :: Word32 -> Word8 -> TBuilder.Builder-rangeToDotDecimalBuilder addr len =- toDotDecimalBuilder addr- <> TBuilder.singleton '/'- <> decimal len---- | 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 :: Word32 -> Text-toTextPreAllocated 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--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 threeDigitsWord8--putMac :: ByteString -> Int -> Word64 -> TArray.MArray s -> ST s ()-putMac hexPairs pos w' marr = do- let w = fromIntegral w'- i = w + w- TArray.unsafeWrite marr pos $ fromIntegral $ ByteString.unsafeIndex hexPairs i- TArray.unsafeWrite marr (pos + 1) $ fromIntegral $ ByteString.unsafeIndex hexPairs (i + 1)-{-# INLINE putMac #-}--word48AsOctets :: Word48 -> (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> a) -> a-word48AsOctets w f =- let w1 = fromIntegral $ unsafeShiftR w 40- w2 = fromIntegral $ unsafeShiftR w 32- w3 = fromIntegral $ unsafeShiftR w 24- w4 = fromIntegral $ unsafeShiftR w 16- w5 = fromIntegral $ unsafeShiftR w 8- w6 = fromIntegral w- in f w1 w2 w3 w4 w5 w6-{-# INLINE word48AsOctets #-}--macToTextDefault :: Word48 -> Text-macToTextDefault = macToTextPreAllocated 58 False--macToTextPreAllocated :: Word8 -> Bool -> Word48 -> Text-macToTextPreAllocated separator' isUpperCase w =- let w1 = 255 .&. unsafeShiftR (fromIntegral w) 40- w2 = 255 .&. unsafeShiftR (fromIntegral w) 32- w3 = 255 .&. unsafeShiftR (fromIntegral w) 24- w4 = 255 .&. unsafeShiftR (fromIntegral w) 16- w5 = 255 .&. unsafeShiftR (fromIntegral w) 8- w6 = 255 .&. fromIntegral w- in macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6-{-# INLINE macToTextPreAllocated #-}--macToTextPartTwo :: Word8 -> Bool -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Text-macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6 =-#ifdef ghcjs_HOST_OS- Text.pack $ concat- [ toHex w1- , separatorStr- , toHex w2- , separatorStr- , toHex w3- , separatorStr- , toHex w4- , separatorStr- , toHex w5- , separatorStr- , toHex w6- ]- where- toHex :: Word64 -> String- toHex = if isUpperCase then printf "%02X" else printf "%02x"- separatorStr = [chr (fromEnum separator')]-#else- let hexPairs = if isUpperCase then twoHexDigits else twoHexDigitsLower- separator = fromIntegral separator' :: Word16- arr = runST $ do- marr <- TArray.new 17- putMac hexPairs 0 w1 marr- TArray.unsafeWrite marr 2 separator- putMac hexPairs 3 w2 marr- TArray.unsafeWrite marr 5 separator- putMac hexPairs 6 w3 marr- TArray.unsafeWrite marr 8 separator- putMac hexPairs 9 w4 marr- TArray.unsafeWrite marr 11 separator- putMac hexPairs 12 w5 marr- TArray.unsafeWrite marr 14 separator- putMac hexPairs 15 w6 marr- TArray.unsafeFreeze marr- in Text arr 0 17-#endif-{-# INLINE macToTextPartTwo #-}---zero :: Word16-zero = 48-{-# INLINE zero #-}--i2w :: Integral a => a -> Word16-i2w v = zero + fromIntegral v-{-# INLINE i2w #-}---fromDotDecimalText' :: Text -> Either String Word32-fromDotDecimalText' t =- AT.parseOnly (dotDecimalParser <* AT.endOfInput) t--fromDotDecimalText :: Text -> Maybe Word32-fromDotDecimalText = rightToMaybe . fromDotDecimalText'--rangeFromDotDecimalText' :: (Word32 -> Word8 -> a) -> Text -> Either String a-rangeFromDotDecimalText' f t =- AT.parseOnly (dotDecimalRangeParser f <* AT.endOfInput) t-{-# INLINE rangeFromDotDecimalText' #-}--rangeFromDotDecimalText :: (Word32 -> Word8 -> a) -> Text -> Maybe a-rangeFromDotDecimalText f = rightToMaybe . rangeFromDotDecimalText' f--dotDecimalRangeParser :: (Word32 -> Word8 -> a) -> AT.Parser a-dotDecimalRangeParser f = f- <$> dotDecimalParser- <* AT.char '/'- <*> (AT.decimal >>= limitSize)- where- limitSize i =- if i > 32- then fail "An IP range length must be between 0 and 32"- else return i---- | This does not do an endOfInput check because it is--- reused in the range parser implementation.-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- limitSize i =- if i > 255- then fail ipOctetSizeErrorMsg- else return i---- | This is sort of a misnomer. It takes Word32 to make--- dotDecimalParser probably perform better. This is mostly--- for internal use.------ At some point, it would be worth revisiting the decision--- to use 'Word32' here. Using 'Word' would probably give--- better performance on a 64-bit processor.-fromOctets' :: Word32 -> Word32 -> Word32 -> Word32 -> Word32-fromOctets' a b c d =- ( shiftL a 24- .|. shiftL b 16- .|. shiftL c 8- .|. d- )--fromOctetsV6 ::- Word64 -> Word64 -> Word64 -> Word64- -> Word64 -> Word64 -> Word64 -> Word64- -> Word64 -> Word64 -> Word64 -> Word64- -> Word64 -> Word64 -> Word64 -> Word64- -> (Word64,Word64)-fromOctetsV6 a b c d e f g h i j k l m n o p =- ( fromOctetsWord64 a b c d e f g h- , fromOctetsWord64 i j k l m n o p- )--fromWord16sV6 ::- Word64 -> Word64 -> Word64 -> Word64- -> Word64 -> Word64 -> Word64 -> Word64- -> (Word64,Word64)-fromWord16sV6 a b c d e f g h =- ( fromWord16Word64 a b c d- , fromWord16Word64 e f g h- )--fromWord16Word64 :: Word64 -> Word64 -> Word64 -> Word64 -> Word64-fromWord16Word64 a b c d = fromIntegral- ( unsafeShiftL a 48- .|. unsafeShiftL b 32- .|. unsafeShiftL c 16- .|. d- )---- | All the words given as argument should be--- range restricted from 0 to 255. This is not--- checked.-fromOctetsWord64 ::- Word64 -> Word64 -> Word64 -> Word64- -> Word64 -> Word64 -> Word64 -> Word64- -> Word64-fromOctetsWord64 a b c d e f g h = fromIntegral- ( shiftL a 56- .|. shiftL b 48- .|. shiftL c 40- .|. shiftL d 32- .|. shiftL e 24- .|. shiftL f 16- .|. shiftL g 8- .|. h- )---- | 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.-countAddrs :: Word8 -> Word64-countAddrs w =- let amountToShift = if w > 32- then 0- else 32 - fromIntegral w- in shift 1 amountToShift--wordSuccessors :: Word64 -> Word32 -> [Word32]-wordSuccessors !w !a = if w > 0- then a : wordSuccessors (w - 1) (a + 1)- else []--wordSuccessorsM :: MonadPlus m => (Word32 -> a) -> Word64 -> Word32 -> m a-wordSuccessorsM f = go where- go !w !a = if w > 0- then mplus (return (f a)) (go (w - 1) (a + 1))- else mzero-{-# INLINE wordSuccessorsM #-}--mask :: Word8 -> Word32-mask = complement . shiftR 0xffffffff . fromIntegral--p24 :: Word32-p24 = fromOctets' 10 0 0 0--p20 :: Word32-p20 = fromOctets' 172 16 0 0--p16 :: Word32-p16 = fromOctets' 192 168 0 0--mask8,mask4,mask12,mask20,mask28,mask16,mask10,mask24,mask32,mask15 :: Word32-mask4 = 0xF0000000-mask8 = 0xFF000000-mask10 = 0xFFC00000-mask12 = 0xFFF00000-mask15 = 0xFFFE0000-mask16 = 0xFFFF0000-mask20 = 0xFFFFF000-mask24 = 0xFFFFFF00-mask28 = 0xFFFFFFF0-mask32 = 0xFFFFFFFF---- r1,r2,r3,r4,r5,r6 :: Word32--- r1 = fromOctets' 0 0 0 0--macTextParser :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> AT.Parser a-macTextParser separator f = f- <$> (AT.hexadecimal >>= limitSize)- <* parseSeparator- <*> (AT.hexadecimal >>= limitSize)- <* parseSeparator- <*> (AT.hexadecimal >>= limitSize)- <* parseSeparator- <*> (AT.hexadecimal >>= limitSize)- <* parseSeparator- <*> (AT.hexadecimal >>= limitSize)- <* parseSeparator- <*> (AT.hexadecimal >>= limitSize)- where- parseSeparator = case separator of- Just c -> AT.char c- Nothing -> return 'x' -- character is unused- limitSize i =- if i > 255- then fail "All octets in a mac address must be between 00 and FF"- else return i---- Unchecked invariant: each of these Word64s must be smaller--- than 256.-unsafeWord48FromOctets :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word48-unsafeWord48FromOctets a b c d e f =- fromIntegral- $ unsafeShiftL a 40- .|. unsafeShiftL b 32- .|. unsafeShiftL c 24- .|. unsafeShiftL d 16- .|. unsafeShiftL e 8- .|. f-{-# INLINE unsafeWord48FromOctets #-}--macFromText :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Maybe a-macFromText separator f = rightToMaybe . macFromText' separator f-{-# INLINE macFromText #-}--macFromText' :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Either String a-macFromText' separator f =- AT.parseOnly (macTextParser separator f <* AT.endOfInput)-{-# INLINE macFromText' #-}--twoDigits :: ByteString-twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99-{-# NOINLINE twoDigits #-}--threeDigitsWord8 :: ByteString-threeDigitsWord8 = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 255-{-# NOINLINE threeDigitsWord8 #-}--twoHexDigits :: ByteString-twoHexDigits = foldMap (BC8.pack . printf "%02X") $ enumFromTo (0 :: Int) 255-{-# NOINLINE twoHexDigits #-}--twoHexDigitsLower :: ByteString-twoHexDigitsLower = foldMap (BC8.pack . printf "%02x") $ enumFromTo (0 :: Int) 255-{-# NOINLINE twoHexDigitsLower #-}-
src/Net/Mac.hs view
@@ -1,23 +1,174 @@- {-# LANGUAGE DeriveGeneric #-}- {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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+ with it.+-} module Net.Mac- ( fromOctets+ ( -- * Convert+ mac+ , fromOctets , toOctets++ -- * Textual Conversion++ -- ** Text+ , encode+ , encodeWith+ , decode+ , decodeWith+ , builder+ , parser+ , parserWith++ -- ** ShortText+ , encodeShort++ -- ** UTF-8 ByteString+ , encodeUtf8+ , encodeWithUtf8+ , decodeUtf8+ , decodeWithUtf8+ , builderUtf8+ , parserUtf8+ , parserWithUtf8++ -- ** ByteString+ , decodeBytes+ , decodeOctets++ -- ** UTF-8 Bytes+ , boundedBuilderUtf8+ , decodeUtf8Bytes+ , parserUtf8Bytes++ -- ** Printing+ , print++ -- * Default Codec+ , defCodec++ -- * Types+ , Mac (..)+ , MacCodec (..)+ , MacGrouping (..) ) where -import Net.Types (Mac(..))+import Prelude hiding (print)++import Control.DeepSeq (NFData)+import Data.Aeson (FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..))+import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))+import Data.ByteString (ByteString)+import Data.ByteString.Short.Internal (ShortByteString (SBS))+import Data.Char (chr, ord)+import Data.Data (Data)+import Data.Hashable (Hashable)+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.Bits ((.&.),(.|.),shiftR,shiftL,complement,unsafeShiftR)-import qualified Net.Internal as Internal+import Data.Word.Synthetic.Word12 (Word12)+import GHC.Enum (predError, succError)+import GHC.Exts+import GHC.Generics (Generic)+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+import qualified Data.Attoparsec.ByteString as ABW+import qualified Data.Attoparsec.Text as AT+import qualified Data.ByteString as B+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.Short.Unsafe as TS+import qualified GHC.Prim.Compat as Compat+import qualified GHC.Word.Compat as Compat++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as AK+#endif++{- | 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 $ Internal.unsafeWord48FromOctets- (fromIntegral a) (fromIntegral b) (fromIntegral c)- (fromIntegral d) (fromIntegral e) (fromIntegral f)-{-# INLINE fromOctets #-}+fromOctets a b c d e f =+ Mac $+ unsafeWord48FromOctets+ (fromIntegral a)+ (fromIntegral b)+ (fromIntegral c)+ (fromIntegral d)+ (fromIntegral e)+ (fromIntegral 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@@ -27,3 +178,819 @@ , fromIntegral w ) +{- | This function is deprecated. It will be renamed in a future release+ since the name is misleading.+-}+decodeBytes :: ByteString -> Maybe Mac+{-# 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 (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 $ 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+ True -> TFB.run (fixedBuilderNoSeparator TFB.word8HexFixedUpper) m+ False -> TFB.run (fixedBuilderNoSeparator TFB.word8HexFixedLower) m+ 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)+ MacGroupingTriples c -> case u of+ True -> TFB.run (fixedBuilderTriples TFB.word12HexFixedUpper) (Pair c m)+ False -> TFB.run (fixedBuilderTriples TFB.word12HexFixedLower) (Pair c m)+ MacGroupingQuadruples c -> case u of+ 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'.++ >>> 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'.++>>> 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)++-- | Encode a 'Mac' address as a 'TBuilder.Builder'.+builder :: Mac -> TBuilder.Builder+builder = TBuilder.fromText . encode++{- | 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 = 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+ MacGroupingTriples c -> parserTriples c+ MacGroupingPairs c -> parserPairs c+ MacGroupingNoSeparator -> parserNoSeparator++{- | 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++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++parserTriples :: Char -> AT.Parser Mac+parserTriples s = do+ a1 <- parseOneHex+ a2 <- parseOneHex+ a3 <- parseOneHex+ _ <- AT.char s+ a4 <- parseOneHex+ a5 <- parseOneHex+ a6 <- parseOneHex+ _ <- AT.char s+ a7 <- parseOneHex+ a8 <- parseOneHex+ a9 <- parseOneHex+ _ <- AT.char s+ 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)++parserNoSeparator :: AT.Parser Mac+parserNoSeparator =+ fromOctets+ <$> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex+ <*> parseTwoHex++parseTwoHex :: AT.Parser Word8+parseTwoHex = do+ a <- AT.anyChar >>= parseCharHex+ b <- AT.anyChar >>= parseCharHex+ return (unsafeShiftL a 4 + b)++tryParseCharHex :: AT.Parser Word8 -> Char -> AT.Parser Word8+tryParseCharHex a c+ | w >= 48 && w <= 57 = return (w - 48)+ | w >= 65 && w <= 70 = return (w - 55)+ | w >= 97 && w <= 102 = return (w - 87)+ | otherwise = a+ where+ w = c2w c++parseOneHex :: AT.Parser Word8+parseOneHex = AT.anyChar >>= parseCharHex++parseCharHex :: Char -> AT.Parser Word8+parseCharHex = tryParseCharHex (fail "invalid hexadecimal character")++data Pair = Pair+ { pairSep :: {-# UNPACK #-} !Char+ , pairMac :: {-# UNPACK #-} !Mac+ }++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+{-# 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+{-# 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+{-# 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+{-# INLINE fixedBuilderPairs #-}++word8At :: Int -> Mac -> Word8+word8At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word8At #-}++word12At :: Int -> Mac -> Word12+word12At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word12At #-}++{- | 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.++ >>> 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'.++ >>> 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)++{- | 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@).+-}+parserUtf8 :: AB.Parser Mac+parserUtf8 = parserLenientUtf8++-- | Parser for a 'Mac' address using the provided settings.+parserWithUtf8 :: MacCodec -> AB.Parser Mac+parserWithUtf8 (MacCodec g _) = case g of+ MacGroupingPairs s -> parserPairsUtf8 (c2w s)+ MacGroupingTriples s -> parserTriplesUtf8 (c2w s)+ MacGroupingQuadruples s -> parserQuadruplesUtf8 (c2w s)+ MacGroupingNoSeparator -> parserNoSeparatorUtf8++parserLenientUtf8 :: AB.Parser Mac+parserLenientUtf8 = do+ a1 <- parseOneHexUtf8+ a2 <- parseOneHexLenientUtf8+ a3 <- parseOneHexLenientUtf8+ a4 <- parseOneHexLenientUtf8+ a5 <- parseOneHexLenientUtf8+ a6 <- parseOneHexLenientUtf8+ a7 <- parseOneHexLenientUtf8+ a8 <- parseOneHexLenientUtf8+ a9 <- parseOneHexLenientUtf8+ 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)++parserNoSeparatorUtf8 :: AB.Parser Mac+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++parserTriplesUtf8 :: Word8 -> AB.Parser Mac+parserTriplesUtf8 s = do+ a1 <- parseOneHexUtf8+ a2 <- parseOneHexUtf8+ a3 <- parseOneHexUtf8+ _ <- ABW.word8 s+ a4 <- parseOneHexUtf8+ a5 <- parseOneHexUtf8+ a6 <- parseOneHexUtf8+ _ <- ABW.word8 s+ a7 <- parseOneHexUtf8+ a8 <- parseOneHexUtf8+ a9 <- parseOneHexUtf8+ _ <- ABW.word8 s+ 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)++parserQuadruplesUtf8 :: Word8 -> AB.Parser Mac+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.+-}+parseOneHexLenientUtf8 :: AB.Parser Word8+parseOneHexLenientUtf8 = do+ a <- ABW.anyWord8+ flip tryParseWord8Hex a $ do+ b <- ABW.anyWord8+ tryParseWord8Hex (fail "invalid hexadecimal character") b++parseTwoHexUtf8 :: AB.Parser Word8+parseTwoHexUtf8 = do+ a <- ABW.anyWord8 >>= parseWord8Hex+ 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.+-}+tryParseWord8Hex :: AB.Parser Word8 -> Word8 -> AB.Parser Word8+tryParseWord8Hex a w+ | w >= 48 && w <= 57 = return (w - 48)+ | w >= 65 && w <= 70 = return (w - 55)+ | w >= 97 && w <= 102 = return (w - 87)+ | otherwise = a++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 $ 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+ True -> BFB.run (fixedBuilderNoSeparatorUtf8 BFB.word8HexFixedUpper) m+ False -> BFB.run (fixedBuilderNoSeparatorUtf8 BFB.word8HexFixedLower) m+ 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)+ 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)+ MacGroupingQuadruples c -> case u of+ True -> BFB.run (fixedBuilderQuadruplesUtf8 BFB.word8HexFixedUpper) (PairUtf8 (c2w c) m)+ False -> BFB.run (fixedBuilderQuadruplesUtf8 BFB.word8HexFixedLower) (PairUtf8 (c2w c) m)++data PairUtf8 = PairUtf8+ { pairSepUtf8 :: {-# UNPACK #-} !Word8+ , pairMacUtf8 :: {-# UNPACK #-} !Mac+ }++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+{-# 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+{-# 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+{-# 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+{-# INLINE fixedBuilderNoSeparatorUtf8 #-}++word8AtUtf8 :: Int -> Mac -> Word8+word8AtUtf8 i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word8AtUtf8 #-}++word12AtUtf8 :: Int -> Mac -> Word12+word12AtUtf8 i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word12AtUtf8 #-}++{- | 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#+ (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 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 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#)+ then case writeByteArray# arr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0+ setOffAddr# addr# i# len# ident = go 0#+ where+ go ix# s0 =+ if isTrue# (ix# <# len#)+ then case writeOffAddr# addr# (i# +# ix#) ident s0 of+ s1 -> go (ix# +# 1#) s1+ else s0++macToWord16A# :: Mac -> Word#+{-# INLINE macToWord16A# #-}+macToWord16A# (Mac w) = case word64ToWord16 (unsafeShiftR w 32) of+ Compat.W16# x -> x++macToWord16B# :: Mac -> Word#+{-# INLINE macToWord16B# #-}+macToWord16B# (Mac w) = case word64ToWord16 (unsafeShiftR w 16) of+ Compat.W16# x -> x++macToWord16C# :: Mac -> Word#+{-# INLINE macToWord16C# #-}+macToWord16C# (Mac w) = case word64ToWord16 w of+ Compat.W16# x -> x++macFromWord16# :: Word# -> Word# -> Word# -> Mac+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++word64ToWord16 :: Word64 -> Word16+word64ToWord16 = fromIntegral++-- What this instance does is to display the+-- inner contents in hexadecimal and pad them out to+-- 6 bytes in case it begins with several zeroes.+-- 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++instance Read Mac where+ readPrec = parens $ prec 10 $ do+ Ident "mac" <- lexP+ w <- step readPrec+ return (mac w)++instance Bounded Mac where+ minBound = Mac 0+ maxBound = Mac 0xFFFFFFFFFFFF++instance Enum Mac where+ succ m@(Mac x)+ | m == maxBound = succError "Mac"+ | otherwise = Mac (x + 1)+ pred m@(Mac x)+ | m == minBound = predError "Mac"+ | otherwise = Mac (x - 1)+ toEnum i = Mac (toEnum i)+ fromEnum (Mac x) = fromEnum x++-- | Print a 'Mac' address using the textual encoding.+print :: Mac -> IO ()+print = TIO.putStrLn . encode++showHexWord48 :: Word64 -> ShowS+showHexWord48 w = showString "0x" . go 11+ where+ go :: Int -> ShowS+ 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.+-}+data MacCodec = MacCodec+ { macCodecGrouping :: !MacGrouping+ , macCodecUpperCase :: !Bool+ }+ 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.+-}+data MacGrouping+ = -- | 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++instance ToJSONKey Mac where+ 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++instance FromJSON Mac where+ parseJSON = attoparsecParseJSON parser++attoparsecParseJSON :: AT.Parser a -> Aeson.Value -> Aeson.Parser a+attoparsecParseJSON p v =+ case v of+ Aeson.String t ->+ case AT.parseOnly p t of+ Left err -> fail err+ Right res -> return res+ _ -> fail "expected a String"++-- Unchecked invariant: each of these Word64s must be smaller+-- 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
− src/Net/Mac/ByteString/Char8.hs
@@ -1,254 +0,0 @@-module Net.Mac.ByteString.Char8- ( encode- , encodeWith- , decode- , decodeWith- , decodeLenient- , builder- , parser- , parserWith- , parserLenient- ) where--import Net.Types (Mac(..),MacCodec(..),MacGrouping(..))-import Net.Mac (fromOctets)-import Data.ByteString (ByteString)-import Data.Attoparsec.ByteString.Char8 (Parser)-import Data.ByteString.Lazy.Builder (Builder)-import Net.Internal (rightToMaybe,c2w)-import Data.Text.Encoding (encodeUtf8, decodeUtf8')-import Data.Word (Word8)-import Data.Word.Synthetic (Word12)-import Data.Bits (unsafeShiftL,unsafeShiftR)-import Control.Monad-import Data.Monoid-import qualified Data.ByteString.Builder.Fixed as FB-import qualified Data.ByteString.Builder as Builder-import qualified Data.Attoparsec.ByteString as ABW-import qualified Data.Attoparsec.ByteString.Char8 as AB--encode :: Mac -> ByteString-encode = encodeWith defCodec--decode :: ByteString -> Maybe Mac-decode = decodeWith defCodec--decodeWith :: MacCodec -> ByteString -> Maybe Mac-decodeWith codec bs = rightToMaybe (AB.parseOnly (parserWith codec <* AB.endOfInput) bs)--decodeLenient :: ByteString -> Maybe Mac-decodeLenient bs = rightToMaybe (AB.parseOnly (parserLenient <* AB.endOfInput) bs)---- | Make a bytestring builder from a 'Mac' address--- using a colon as the separator.-builder :: Mac -> Builder-builder = Builder.byteString . encode---- | Parser for a 'Mac' address using with a colon as the--- separator (i.e. @FA:43:B2:C0:0F:99@).-parser :: Parser Mac-parser = parserWith defCodec---- | Parser for a 'Mac' address using the provided settings.-parserWith :: MacCodec -> Parser Mac-parserWith (MacCodec g _) = case g of- MacGroupingPairs s -> parserPairs (c2w s)- MacGroupingTriples s -> parserTriples (c2w s)- MacGroupingQuadruples s -> parserQuadruples (c2w s)- MacGroupingNoSeparator -> parserNoSeparator--parserLenient :: Parser Mac-parserLenient = do- a1 <- parseOneHex- a2 <- parseOneHexLenient- a3 <- parseOneHexLenient- a4 <- parseOneHexLenient- a5 <- parseOneHexLenient- a6 <- parseOneHexLenient- a7 <- parseOneHexLenient- a8 <- parseOneHexLenient- a9 <- parseOneHexLenient- a10 <- parseOneHexLenient- a11 <- parseOneHexLenient- a12 <- parseOneHexLenient- 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 :: Parser Mac-parserNoSeparator = fromOctets- <$> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex--parserPairs :: Word8 -> Parser Mac-parserPairs s = fromOctets- <$> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex--parserTriples :: Word8 -> Parser Mac-parserTriples s = do- a1 <- parseOneHex- a2 <- parseOneHex- a3 <- parseOneHex- _ <- ABW.word8 s- a4 <- parseOneHex- a5 <- parseOneHex- a6 <- parseOneHex- _ <- ABW.word8 s- a7 <- parseOneHex- a8 <- parseOneHex- a9 <- parseOneHex- _ <- ABW.word8 s- 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)--parserQuadruples :: Word8 -> Parser Mac-parserQuadruples s = fromOctets- <$> parseTwoHex <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <*> parseTwoHex <* ABW.word8 s- <*> parseTwoHex <*> parseTwoHex--parseOneHex :: Parser Word8-parseOneHex = ABW.anyWord8 >>= parseWord8Hex---- | Parse a single hexidecimal character. This will skip--- at most one character to do this.-parseOneHexLenient :: Parser Word8-parseOneHexLenient = do- a <- ABW.anyWord8- flip tryParseWord8Hex a $ do- b <- ABW.anyWord8- tryParseWord8Hex (fail "invalid hexadecimal character") b--parseTwoHex :: Parser Word8-parseTwoHex = do- a <- ABW.anyWord8 >>= parseWord8Hex- 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.-tryParseWord8Hex :: Parser Word8 -> Word8 -> Parser Word8-tryParseWord8Hex a w- | w >= 48 && w <= 57 = return (w - 48)- | w >= 65 && w <= 70 = return (w - 55)- | w >= 97 && w <= 102 = return (w - 87)- | otherwise = a--parseWord8Hex :: Word8 -> Parser Word8-parseWord8Hex = tryParseWord8Hex (fail "invalid hexadecimal character")--defCodec :: MacCodec-defCodec = MacCodec (MacGroupingPairs ':') False--encodeWith :: MacCodec -> Mac -> ByteString-encodeWith (MacCodec g u) m = case g of- MacGroupingNoSeparator -> case u of- True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m- False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m- MacGroupingPairs c -> case u of- True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair (c2w c) m)- False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair (c2w c) m)- -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m)- MacGroupingTriples c -> case u of- True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair (c2w c) m)- False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair (c2w c) m)- MacGroupingQuadruples c -> case u of- True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair (c2w c) m)- False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair (c2w c) m)--withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a-withCasedBuilder x f = case x of- True -> f FB.word8HexFixedUpper- False -> f FB.word8HexFixedLower-{-# INLINE withCasedBuilder #-}--withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a-withCasedBuilderTriple x f = case x of- True -> f FB.word12HexFixedUpper- False -> f FB.word12HexFixedLower-{-# INLINE withCasedBuilderTriple #-}--data Pair = Pair- { pairSep :: {-# UNPACK #-} !Word8- , pairMac :: {-# UNPACK #-} !Mac- }--fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair-fixedBuilderTriples tripBuilder =- FB.contramapBuilder (word12At 36 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder-{-# INLINE fixedBuilderTriples #-}--fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair-fixedBuilderQuadruples pairBuilder =- FB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder-{-# INLINE fixedBuilderQuadruples #-}--fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair-fixedBuilderPairs pairBuilder =- FB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.word8- <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder-{-# INLINE fixedBuilderPairs #-}--fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac-fixedBuilderNoSeparator hexBuilder =- FB.contramapBuilder (word8At 40) hexBuilder- <> FB.contramapBuilder (word8At 32) hexBuilder- <> FB.contramapBuilder (word8At 24) hexBuilder- <> FB.contramapBuilder (word8At 16) hexBuilder- <> FB.contramapBuilder (word8At 8) hexBuilder- <> FB.contramapBuilder (word8At 0) hexBuilder-{-# INLINE fixedBuilderNoSeparator #-}--word8At :: Int -> Mac -> Word8-word8At i (Mac w) = fromIntegral (unsafeShiftR w i)-{-# INLINE word8At #-}--word12At :: Int -> Mac -> Word12-word12At i (Mac w) = fromIntegral (unsafeShiftR w i)-{-# INLINE word12At #-}-
− src/Net/Mac/Text.hs
@@ -1,221 +0,0 @@-module Net.Mac.Text- ( encode- , encodeWith- , decode- , decodeWith- , decodeEither- , decodeEitherWith- , builder- , parser- , parserWith- ) where--import Net.Types (Mac(..),MacCodec(..),MacGrouping(..))-import Net.Mac (fromOctets)--- import Net.Mac (fromOctetsNoCast)-import Data.Text (Text)-import Data.Word (Word8)-import Data.Word.Synthetic (Word12)-import Data.Char (chr)-import Data.Attoparsec.Text (Parser)-import Net.Internal (rightToMaybe,c2w)-import Data.Bits (unsafeShiftL,unsafeShiftR)-import Data.Monoid-import qualified Net.Internal as Internal-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Builder.Fixed as FB--encode :: Mac -> Text-encode = encodeWith defCodec -- Internal.macToTextDefault w--encodeWith :: MacCodec -> Mac -> Text-encodeWith (MacCodec g u) m = case g of- MacGroupingNoSeparator -> case u of- True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m- False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m- MacGroupingPairs c -> case u of- True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair c m)- False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair c m)- -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m)- MacGroupingTriples c -> case u of- True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair c m)- False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair c m)- MacGroupingQuadruples c -> case u of- True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair c m)- False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair c m)--withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a-withCasedBuilder x f = case x of- True -> f FB.word8HexFixedUpper- False -> f FB.word8HexFixedLower-{-# INLINE withCasedBuilder #-}---decodeEitherWith :: MacCodec -> Text -> Either String Mac-decodeEitherWith codec t = AT.parseOnly (parserWith codec <* AT.endOfInput) t--decodeEither :: Text -> Either String Mac-decodeEither = decodeEitherWith defCodec--decode :: Text -> Maybe Mac-decode = decodeWith defCodec--decodeWith :: MacCodec -> Text -> Maybe Mac-decodeWith codec t = rightToMaybe (AT.parseOnly (parserWith codec <* AT.endOfInput) t)--builder :: Mac -> TBuilder.Builder-builder = TBuilder.fromText . encode--parser :: AT.Parser Mac-parser = parserWith defCodec--parserWith :: MacCodec -> AT.Parser Mac-parserWith (MacCodec g _) = case g of- MacGroupingQuadruples c -> parserQuadruples c- MacGroupingTriples c -> parserTriples c- MacGroupingPairs c -> parserPairs c- MacGroupingNoSeparator -> parserNoSeparator---defCodec :: MacCodec-defCodec = MacCodec (MacGroupingPairs ':') False--w8ToChar :: Word8 -> Char-w8ToChar = chr . fromIntegral--parserQuadruples :: Char -> Parser Mac-parserQuadruples s = fromOctets- <$> parseTwoHex <*> parseTwoHex <* AT.char s- <*> parseTwoHex <*> parseTwoHex <* AT.char s- <*> parseTwoHex <*> parseTwoHex--parserPairs :: Char -> 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--parserTriples :: Char -> Parser Mac-parserTriples s = do- a1 <- parseOneHex- a2 <- parseOneHex- a3 <- parseOneHex- _ <- AT.char s- a4 <- parseOneHex- a5 <- parseOneHex- a6 <- parseOneHex- _ <- AT.char s- a7 <- parseOneHex- a8 <- parseOneHex- a9 <- parseOneHex- _ <- AT.char s- 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)--parserNoSeparator :: Parser Mac-parserNoSeparator = fromOctets- <$> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex- <*> parseTwoHex--parseTwoHex :: Parser Word8-parseTwoHex = do- a <- AT.anyChar >>= parseCharHex- b <- AT.anyChar >>= parseCharHex- return (unsafeShiftL a 4 + b)--tryParseCharHex :: Parser Word8 -> Char -> Parser Word8-tryParseCharHex a c- | w >= 48 && w <= 57 = return (w - 48)- | w >= 65 && w <= 70 = return (w - 55)- | w >= 97 && w <= 102 = return (w - 87)- | otherwise = a- where w = c2w c--parseOneHex :: Parser Word8-parseOneHex = AT.anyChar >>= parseCharHex--parseCharHex :: Char -> Parser Word8-parseCharHex = tryParseCharHex (fail "invalid hexadecimal character")--withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a-withCasedBuilderTriple x f = case x of- True -> f FB.word12HexFixedUpper- False -> f FB.word12HexFixedLower-{-# INLINE withCasedBuilderTriple #-}--data Pair = Pair- { pairSep :: {-# UNPACK #-} !Char- , pairMac :: {-# UNPACK #-} !Mac- }--fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair-fixedBuilderTriples tripBuilder =- FB.contramapBuilder (word12At 36 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder-{-# INLINE fixedBuilderTriples #-}--fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac-fixedBuilderNoSeparator hexBuilder =- FB.contramapBuilder (word8At 40) hexBuilder- <> FB.contramapBuilder (word8At 32) hexBuilder- <> FB.contramapBuilder (word8At 24) hexBuilder- <> FB.contramapBuilder (word8At 16) hexBuilder- <> FB.contramapBuilder (word8At 8) hexBuilder- <> FB.contramapBuilder (word8At 0) hexBuilder-{-# INLINE fixedBuilderNoSeparator #-}--fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair-fixedBuilderQuadruples pairBuilder =- FB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder-{-# INLINE fixedBuilderQuadruples #-}--fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair-fixedBuilderPairs pairBuilder =- FB.contramapBuilder (word8At 40 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder- <> FB.contramapBuilder pairSep FB.charBmp- <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder-{-# INLINE fixedBuilderPairs #-}--word8At :: Int -> Mac -> Word8-word8At i (Mac w) = fromIntegral (unsafeShiftR w i)-{-# INLINE word8At #-}--word12At :: Int -> Mac -> Word12-word12At i (Mac w) = fromIntegral (unsafeShiftR w i)-{-# INLINE word12At #-}
src/Net/Types.hs view
@@ -1,327 +1,16 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}--{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-+-- | This module re-exports all of the thematic types that this library defines. module Net.Types- ( IPv4(..)- , IPv6(..)- , IP(..)- , IPv4Range(..)- , Mac(..)- , MacCodec(..)- , MacGrouping(..)+ ( IPv4 (..)+ , IPv6 (..)+ , IP (..)+ , IPv4Range (..)+ , IPv6Range (..)+ , Mac (..)+ , MacCodec (..)+ , MacGrouping (..) ) where -import qualified Net.Internal as Internal-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson-import qualified Data.Attoparsec.Text as AT--- import qualified Data.Vector.Generic as G--- import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Generic as GVector-import qualified Data.Vector.Unboxed as UVector-import qualified Data.Vector.Primitive as PVector-import qualified Data.Vector.Generic.Mutable as MGVector-import qualified Data.Vector.Unboxed.Mutable as MUVector-import qualified Data.Vector.Primitive.Mutable as MPVector-import qualified Data.Text.Encoding as TE-import qualified Data.ByteString.Builder as BB-import Foreign.Storable (Storable(..))-import Data.Word.Synthetic (Word48)-import Data.Primitive.Types (Prim)-import Data.Bits (Bits,FiniteBits,(.|.),unsafeShiftL)-import Data.Coerce (coerce)-import Control.Monad-import Data.Word-import Data.Int-import Data.Hashable-import Data.Aeson (FromJSON(..),ToJSON(..))-import GHC.Generics (Generic)-import Data.Monoid--#if MIN_VERSION_aeson(1,0,0) -import qualified Data.Aeson.Encoding as Aeson-import Data.Aeson (ToJSONKey(..),FromJSONKey(..),- ToJSONKeyFunction(..),FromJSONKeyFunction(..))-#endif---- | A 32-bit Internet Protocol version 4 address.-newtype IPv4 = IPv4 { getIPv4 :: Word32 }- deriving (Eq,Ord,Show,Read,Enum,Bounded,Hashable,Generic,Prim,Bits,FiniteBits,Storable)---- | A 128-bit Internet Protocol version 6 address.-data IPv6 = IPv6- { ipv6A :: {-# UNPACK #-} !Word64- , ipv6B :: {-# UNPACK #-} !Word64- } deriving (Eq,Ord,Show,Read)---- | 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 pattern matching on it.-newtype IP = IP { getIP :: IPv6 }- deriving (Eq,Ord,Show,Read)---- | 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)---- | A 48-bit MAC address.-newtype Mac = Mac { getMac :: Word48 }- deriving (Eq,Ord,Show,Read,Generic)---- data MacEncoding = MacEncoding--- { macEncodingSeparator :: {-# UNPACK #-} !Word8 -- ^ ASCII value of the separator--- , macEncodingUpperCase :: {-# UNPACK #-} !Bool--- } deriving (Eq,Ord,Show,Read,Generic)--data MacCodec = MacCodec- { macCodecGrouping :: !MacGrouping- , macCodecUpperCase :: !Bool- } deriving (Eq,Ord,Show,Read,Generic)---- | 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--instance ToJSON Mac where- toJSON (Mac w) = Aeson.String (Internal.macToTextDefault w)--#if MIN_VERSION_aeson(1,0,0) -instance ToJSONKey Mac where- toJSONKey = ToJSONKeyText- (\(Mac w) -> Internal.macToTextDefault w)- -- The bytestring encoding currently goes through text. This is suboptimal.- (\(Mac w) -> Aeson.unsafeToEncoding $ BB.char7 '"' <> BB.byteString (TE.encodeUtf8 $ Internal.macToTextDefault w) <> BB.char7 '"')--instance FromJSONKey Mac where- fromJSONKey = FromJSONKeyTextParser $ \t -> - case Internal.macFromText (Just ':') macFromOctets' t of- Nothing -> fail "invalid mac address"- Just mac -> return mac--instance ToJSONKey IPv4 where- toJSONKey = ToJSONKeyText- (\(IPv4 w) -> Internal.toDotDecimalText w)- (\(IPv4 w) -> Aeson.unsafeToEncoding $ BB.char7 '"' <> (BB.byteString $ TE.encodeUtf8 $ Internal.toDotDecimalText w) <> BB.char7 '"')--instance FromJSONKey IPv4 where- fromJSONKey = FromJSONKeyTextParser- (Internal.eitherToAesonParser . coerce Internal.decodeIPv4TextEither)-#endif--instance FromJSON Mac where- parseJSON = Internal.attoparsecParseJSON- (Internal.macTextParser (Just ':') macFromOctets' <* AT.endOfInput)---- Unchecked invariant: each of these Word64s must be smaller--- than 256.-macFromOctets' :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Mac-macFromOctets' a b c d e f = - Mac (Internal.unsafeWord48FromOctets a b c d e f)-{-# INLINE macFromOctets' #-}--instance Hashable IPv4Range--instance ToJSON IPv4 where- toJSON (IPv4 addr) = Aeson.String (Internal.toDotDecimalText addr)--instance FromJSON IPv4 where- parseJSON = Aeson.withText "IPv4" (Internal.eitherToAesonParser . coerce Internal.decodeIPv4TextEither)--instance ToJSON IPv4Range where- toJSON (IPv4Range (IPv4 addr) range) = Aeson.String (Internal.rangeToDotDecimalText addr range)--instance FromJSON IPv4Range where- parseJSON (Aeson.String t) =- case Internal.rangeFromDotDecimalText' mkIPv4Range t of- Left err -> fail err- Right res -> return res- parseJSON _ = mzero--mkIPv4Range :: Word32 -> Word8 -> IPv4Range-mkIPv4Range w len = IPv4Range (IPv4 w) len-{-# INLINE mkIPv4Range #-}--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--data instance MUVector.MVector s IPv4Range- = MV_IPv4Range {-# UNPACK #-} !Int !(MUVector.MVector s IPv4)- !(MUVector.MVector s Word8)-data instance UVector.Vector IPv4Range- = V_IPv4Range {-# UNPACK #-} !Int !(UVector.Vector IPv4)- !(UVector.Vector Word8)-instance UVector.Unbox IPv4Range-instance MGVector.MVector MUVector.MVector IPv4Range where- {-# INLINE basicLength #-}- basicLength (MV_IPv4Range n_ as bs) = n_- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (MV_IPv4Range n_ as bs)- = MV_IPv4Range m_ (MGVector.basicUnsafeSlice i_ m_ as)- (MGVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicOverlaps #-}- basicOverlaps (MV_IPv4Range n_1 as1 bs1) (MV_IPv4Range n_2 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 n_ 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 n_ as bs- {-# INLINE basicUnsafeRead #-}- basicUnsafeRead (MV_IPv4Range n_ as bs) i_- = do- a <- MGVector.basicUnsafeRead as i_- b <- MGVector.basicUnsafeRead bs i_- return (IPv4Range a b)- {-# INLINE basicUnsafeWrite #-}- basicUnsafeWrite (MV_IPv4Range n_ as bs) i_ (IPv4Range a b)- = do- MGVector.basicUnsafeWrite as i_ a- MGVector.basicUnsafeWrite bs i_ b- {-# INLINE basicClear #-}- basicClear (MV_IPv4Range n_ as bs)- = do- MGVector.basicClear as- MGVector.basicClear bs- {-# INLINE basicSet #-}- basicSet (MV_IPv4Range n_ as bs) (IPv4Range a b)- = do- MGVector.basicSet as a- MGVector.basicSet bs b- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_IPv4Range n_1 as1 bs1) (MV_IPv4Range n_2 as2- bs2)- = do- MGVector.basicUnsafeCopy as1 as2- MGVector.basicUnsafeCopy bs1 bs2- {-# INLINE basicUnsafeMove #-}- basicUnsafeMove (MV_IPv4Range n_1 as1 bs1) (MV_IPv4Range n_2 as2- bs2)- = do- MGVector.basicUnsafeMove as1 as2- MGVector.basicUnsafeMove bs1 bs2- {-# INLINE basicUnsafeGrow #-}- basicUnsafeGrow (MV_IPv4Range n_ as bs) m_- = do- as' <- MGVector.basicUnsafeGrow as m_- bs' <- MGVector.basicUnsafeGrow bs m_- return $ MV_IPv4Range (m_+n_) as' bs'-instance GVector.Vector UVector.Vector IPv4Range where- {-# INLINE basicUnsafeFreeze #-}- basicUnsafeFreeze (MV_IPv4Range n_ as bs)- = do- as' <- GVector.basicUnsafeFreeze as- bs' <- GVector.basicUnsafeFreeze bs- return $ V_IPv4Range n_ as' bs'- {-# INLINE basicUnsafeThaw #-}- basicUnsafeThaw (V_IPv4Range n_ as bs)- = do- as' <- GVector.basicUnsafeThaw as- bs' <- GVector.basicUnsafeThaw bs- return $ MV_IPv4Range n_ as' bs'- {-# INLINE basicLength #-}- basicLength (V_IPv4Range n_ as bs) = n_- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice i_ m_ (V_IPv4Range n_ as bs)- = V_IPv4Range m_ (GVector.basicUnsafeSlice i_ m_ as)- (GVector.basicUnsafeSlice i_ m_ bs)- {-# INLINE basicUnsafeIndexM #-}- basicUnsafeIndexM (V_IPv4Range n_ as bs) i_- = do- a <- GVector.basicUnsafeIndexM as i_- b <- GVector.basicUnsafeIndexM bs i_- return (IPv4Range a b)- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy (MV_IPv4Range n_1 as1 bs1) (V_IPv4Range n_2 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---newtype instance MUVector.MVector s Mac- = MV_Mac (MUVector.MVector s Word48)--newtype instance UVector.Vector Mac- = V_Mac (UVector.Vector Word48)+import Net.IP (IP (..))+import Net.IPv4 (IPv4 (..), IPv4Range (..))+import Net.IPv6 (IPv6 (..), IPv6Range (..))+import Net.Mac (Mac (..), MacCodec (..), MacGrouping (..))
− test/ArbitraryInstances.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module ArbitraryInstances where---- Orphan instances that are needed to make QuickCheck work.--import Net.Types (IPv4(..),IPv4Range(..),Mac(..),MacGrouping(..),MacCodec(..))-import Test.QuickCheck (Arbitrary(..),oneof,Gen,elements)-import Data.Word-import Data.Word.Synthetic--deriving instance Arbitrary IPv4-deriving instance Arbitrary Mac---- This instance can generate masks that exceed the recommended--- length of 32.-instance Arbitrary IPv4Range where- arbitrary = fmap fromTuple arbitrary- where fromTuple (a,b) = IPv4Range a b--instance Arbitrary Word48 where- arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)--instance Arbitrary MacCodec where- arbitrary = MacCodec <$> arbitrary <*> arbitrary--instance Arbitrary MacGrouping where- arbitrary = oneof- [ MacGroupingPairs <$> arbitraryMacSeparator- , MacGroupingTriples <$> arbitraryMacSeparator- , MacGroupingQuadruples <$> arbitraryMacSeparator- , pure MacGroupingNoSeparator- ]--arbitraryMacSeparator :: Gen Char-arbitraryMacSeparator = elements [':','-','.','_']-
test/Bench.hs view
@@ -1,70 +1,126 @@ module Main (main) where import Criterion.Main-import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..))-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Monoid ((<>))-import Data.Text.Lazy.Builder.Int (decimal)-import Data.Text.Internal (Text(..))-import Data.Word-import Data.ByteString (ByteString)-import Control.Monad.ST-import qualified Data.Text as Text-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Array as TArray-import qualified Net.IPv4.Text as IPv4_Text-import qualified Net.Mac.Text as MacText-import qualified Net.Mac.ByteString.Char8 as MacByteString-import qualified Net.Mac as Mac+import Data.Bool (bool)+import Data.Maybe (fromJust)+import Data.Primitive (PrimArray, foldlPrimArray')+import qualified Data.Text as Text+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 Net.IPv4.ByteString.Char8 as NIPBS+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+ 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 MacText.encode mac- , bench "Current Implementation, no separator"- $ whnf (MacText.encodeWith (MacCodec MacGroupingNoSeparator True)) mac- , bench "Current Implementation, quads"- $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac- , bench "Current Implementation, triples"- $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac- ]- , bgroup "Mac to ByteString"- [ bench "Current Implementation, pairs" $ whnf MacByteString.encode mac- , bench "Current Implementation, no separator"- $ whnf (MacByteString.encodeWith (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 NIPBS.encode ipAddr- ]+ [ 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,7 +0,0 @@-import Test.DocTest--main :: IO ()-main = doctest- [ "src/Net/IPv4.hs"- , "src/Net/IPv4/Range.hs"- ]
test/IPv4ByteString1.hs view
@@ -1,44 +1,48 @@ module IPv4ByteString1 where -import Net.Types (IPv4(..))-import Net.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,38 +1,31 @@ module IPv4DecodeText1 where -import Net.Types-import Data.Monoid ((<>))-import Data.Word-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Control.Monad.ST-import Data.Text.Internal (Text(..))-import Data.Text.Lazy.Builder.Int (decimal) import Control.Monad-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Array as TArray-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Read as TextRead-import qualified Data.Text.Lazy.Builder.Int as TBuilder+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@@ -48,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,31 +1,22 @@ module IPv4DecodeText2 where -import Net.Types-import Data.Monoid ((<>))+import qualified Data.Attoparsec.Text as AT+import Data.Bits (shiftL, (.|.))+import Data.Text.Internal (Text (..)) import Data.Word-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Control.Monad.ST-import Data.Text.Internal (Text(..))-import Data.Text.Lazy.Builder.Int (decimal)-import Control.Monad-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text.Array as TArray-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Read as TextRead-import qualified Data.Text.Lazy.Builder.Int as TBuilder+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@@ -41,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,24 +1,18 @@+{-# LANGUAGE CPP #-}+ module IPv4Text1 where -import Net.Types (IPv4(..))-import Data.Text (Text)-import qualified Net.IPv4 as IPv4-import qualified Data.Text as Text-import Text.Read (readMaybe)-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Monoid ((<>))-import Data.Text.Lazy.Builder.Int (decimal)-import Data.Text.Internal (Text(..))-import Data.Word-import Data.ByteString (ByteString) import Control.Monad.ST-import Data.Text.Encoding (encodeUtf8)-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.Lazy as LText-import qualified Data.Text.Lazy.Builder as TBuilder-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@@ -34,8 +28,7 @@ w2 = fromIntegral $ 255 .&. shiftR w 16 w3 = fromIntegral $ 255 .&. shiftR w 8 w4 = fromIntegral $ 255 .&. w- dot = 46- (arr,len) = runST $ do+ (arr, len) = runST $ do marr <- TArray.new 15 i1 <- putAndCount 0 w1 marr let n1 = i1@@ -51,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@@ -72,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,24 +1,11 @@ module IPv4Text2 where -import Net.Types (IPv4(..))+import Data.Bits (shiftR, (.&.)) import Data.Text (Text)-import qualified Net.IPv4 as IPv4-import qualified Data.Text as Text-import Text.Read (readMaybe)-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Monoid ((<>))-import Data.Text.Lazy.Builder.Int (decimal)-import Data.Text.Internal (Text(..))-import Data.Word-import Data.ByteString (ByteString)-import Control.Monad.ST-import Data.Text.Encoding (encodeUtf8)-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Array as TArray+import Data.Text.Lazy.Builder.Int (decimal)+import Net.Types (IPv4 (..)) ----------------------------------------- -- Text Builder implementation. This ends@@ -30,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/IPv4TextVariableBuilder.hs
@@ -1,30 +0,0 @@-module IPv4TextVariableBuilder where--import Net.Types (IPv4(..))-import Data.Text (Text)-import Data.Monoid-import Data.Word-import Data.Bits-import qualified Net.IPv4 as IPv4-import qualified Data.Text as Text-import qualified Data.Text.Builder.Variable as VB--encode :: IPv4 -> Text-encode = VB.run variableBuilder--variableBuilder :: VB.Builder IPv4-variableBuilder =- VB.contramap (word8At 24) VB.word8- <> VB.staticCharBmp '.'- <> VB.contramap (word8At 16) VB.word8- <> VB.staticCharBmp '.'- <> VB.contramap (word8At 8) VB.word8- <> VB.staticCharBmp '.'- <> VB.contramap (word8At 0) VB.word8--word8At :: Int -> IPv4 -> Word8-word8At i (IPv4 w) = fromIntegral (unsafeShiftR w i)-{-# INLINE word8At #-}---
test/Naive.hs view
@@ -1,43 +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.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Data.Monoid ((<>))-import Data.Text.Lazy.Builder.Int (decimal)-import Data.Text.Internal (Text(..))-import Data.Word-import Data.ByteString (ByteString)-import Control.Monad.ST import Data.Text.Encoding (encodeUtf8)-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Array as TArray+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/IPv4Spec.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wno-deprecations #-}++module Net.IPv4Spec (spec) where++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` [ 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/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
test/Test.hs view
@@ -1,243 +1,557 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+ module Main (main) where -import Naive-import Data.List (intercalate)-import Test.QuickCheck (Gen, Arbitrary(..), choose)-import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion,(@?=))-import Numeric (showHex)-import Test.QuickCheck.Property (failed,succeeded,Result(..))-import Data.Word+#if MIN_VERSION_base(4,18,0)+#else+import Control.Applicative (liftA2)+#endif+ import Data.Bifunctor-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 (IPv4(..),IPv4Range(..),Mac(..),IPv6(..))-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.IPv4.Range as IPv4Range-import qualified Net.IPv4.Text as IPv4Text-import qualified Net.IPv6.Text as IPv6Text-import qualified Net.IPv4.ByteString.Char8 as IPv4ByteString import qualified Net.Mac as Mac-import qualified Net.Mac.Text as MacText-import qualified Net.Mac.ByteString.Char8 as MacByteString+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 ArbitraryInstances ()-import qualified Naive+import qualified IPv4ByteString1 import qualified IPv4Text1 import qualified IPv4Text2-import qualified IPv4ByteString1-import qualified IPv4TextVariableBuilder +-- 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 IPv4Text.encode IPv4Text.decode- , PH.testCase "Decode an IP" testIPv4Decode- ] ++ testDecodeFailures- , testGroup "Currently used MAC Text encode/decode"- [ testProperty "Isomorphism"- $ propEncodeDecodeIsoSettings MacText.encodeWith MacText.decodeWith- , PH.testCase "Encode a MAC Address" testMacEncode- ]- , testGroup "Currently used MAC ByteString encode/decode"- [ testProperty "Isomorphism"- $ propEncodeDecodeIsoSettings MacByteString.encodeWith MacByteString.decodeWith- , 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 IPv4ByteString.encode 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 "IP Range Operations"- [ testProperty "Idempotence of normalizing IPv4 range"- $ propIdempotence IPv4Range.normalize- , testProperty "Normalize does not affect membership" propNormalizeMember- , testProperty "Membership agrees with bounds" propMemberUpperLower- , testProperty "Range contains self" propRangeSelf+ 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))+ ]+ ] ]- ] -propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool-propEncodeDecodeIso f g a = g (f a) == Just a+lawsToTest :: Laws -> TestTree+lawsToTest (Laws name pairs) = testGroup name (map (uncurry testProperty) pairs) -propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e)- => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result+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 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-propNormalizeMember i r = IPv4Range.member i r == IPv4Range.member i (IPv4Range.normalize r)+propNormalizeMember i r = IPv4.member i r == IPv4.member i (IPv4.normalize r) propMemberUpperLower :: IPv4 -> IPv4Range -> Bool propMemberUpperLower i r =- (i >= IPv4Range.lowerInclusive r && i <= IPv4Range.upperInclusive r) == IPv4Range.member i r+ (i >= IPv4.lowerInclusive r && i <= IPv4.upperInclusive r) == IPv4.member i r propRangeSelf :: IPv4Range -> Bool-propRangeSelf r = IPv4Range.member (ipv4RangeBase r) r == True+propRangeSelf r = IPv4.member (ipv4RangeBase r) r == True testIPv4Decode :: Assertion-testIPv4Decode = IPv4Text.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 (MacByteString.decodeLenient (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- (IPv4ByteString.parser <* 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- (IPv6Text.parser <* AT.endOfInput)- (Text.pack str)- )+ Just (HexIPv6 (IPv6.fromWord16s a b c d e f g h))+ @=? decode str -testIPv6ParserFailure :: Assertion-testIPv6ParserFailure = do- go "1111:2222:3333:4444:5555:6666::7777:8888"+testIPv6ParserFailure :: (String -> Assertion) -> Assertion+testIPv6ParserFailure go = do+ -- must not start or end in colon:+ go ":::"+ go "1::2:"+ 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"++ -- Incorrect numbers of parts:+ go ""+ go "1111"+ go "1111:2222"+ go "1111:2222:3333"+ go "1111:2222:3333:4444"+ go "1111:2222:3333:4444:5555"+ go "1111:2222:3333:4444:5555:6666"+ go "1111:2222:3333:4444:5555:6666:7777" go "1111:2222:3333:4444:5555:6666:7777:8888:9999"- go "1111:2222:3333:4444:5555:6666:7777:8888::9999"- where- go str =- Left ()- @?= bimap (\_ -> ()) HexIPv6- (AT.parseOnly- (IPv6Text.parser <* AT.endOfInput)- (Text.pack str)++ -- Incorrect use of double-colon:+ go "1111::2222::3333"+ go "1111:2222:3333:4444:5555:6666::7777:8888" -- not needed+ go "1111:2222:3333:4444:5555:6666:7777:8888::9999" -- too long++ -- IPv4 decimal embedded, with not enough parts:+ go "1:127.0.0.1"+ go "1:2:3:127.0.0.1"+ go "1:2:3:4:127.0.0.1"+ go "1:2:3:4:5:127.0.0.1"++ -- IPv4 decimal before double-colon:+ go "1:127.0.0.1::"++ -- Only IPv4:+ go "127.0.0.1"++ -- IPv4 decimal embedded, with too many parts:+ go "1:2:3:4:5:6:7:127.0.0.1"+ go "1:2:3:4:5:6:7:8:127.0.0.1"++expectIPv6ParserFailure :: String -> Assertion+expectIPv6ParserFailure str =+ Left ()+ @=? bimap+ (\_ -> ())+ HexIPv6+ ( AT.parseOnly+ (IPv6.parser <* AT.endOfInput)+ (Text.pack str) ) -testIPv6Encode :: Assertion-testIPv6Encode = do+expectIPv6BytesParserFailure :: String -> Assertion+expectIPv6BytesParserFailure s =+ Nothing+ @=? IPv6.decodeUtf8Bytes (Ascii.fromString s) - -- degenerate cases:- "::" `roundTripsTo` "::"- "1234::" `roundTripsTo` "1234::"- "::1234" `roundTripsTo` "::1234"+testIPv6Encode :: (IPv6 -> Text.Text) -> Assertion+testIPv6Encode enc = do+ -- degenerate cases:+ "::" `roundTripsTo` "::"+ "1234::" `roundTripsTo` "1234::"+ "::1234" `roundTripsTo` "::1234" - -- zero-compression works:- "1234:1234:0000:0000:0000:0000:3456:3434" `roundTripsTo` "1234:1234::3456:3434"+ -- zero-compression works:+ "1234:1234:0000:0000:0000:0000:3456:3434" `roundTripsTo` "1234:1234::3456:3434" - -- picks first case:- "1234:0000:1234:0000:1234:0000:0123:1234" `roundTripsTo` "1234::1234:0:1234:0:123:1234"+ -- picks first case:+ "1234:0000:1234:0000:1234:0000:0123:1234" `roundTripsTo` "1234:0:1234:0:1234:0:123:1234" - -- picks longest case:- "1234:0000:1234:0000:0:0000:0123:1234" `roundTripsTo` "1234:0:1234::123:1234"+ -- picks longest case:+ "1234:0000:1234:0000:0:0000:0123:1234" `roundTripsTo` "1234:0:1234::123:1234" - -- can exclude all but first and last:- "1234::1234" `roundTripsTo` "1234::1234"+ -- can exclude all but first and last:+ "1234::1234" `roundTripsTo` "1234::1234" - -- prefers leftmost part to zero-compress:- "1:2:0:0:5::8" `roundTripsTo` "1:2::5:0:0:8"+ -- prefers leftmost part to zero-compress:+ "1:2:0:0:5::8" `roundTripsTo` "1:2::5:0:0:8" - -- can work with no zeroes:- "1:2:3:4:5:6:7:8" `roundTripsTo` "1:2:3:4:5:6:7:8"+ -- can work with no zeroes:+ "1:2:3:4:5:6:7:8" `roundTripsTo` "1:2:3:4:5:6:7:8" - -- works with only first or last:- "::2:3:4:5:6:7:8" `roundTripsTo` "::2:3:4:5:6:7:8"- "1:2:3:4:5:6:7::" `roundTripsTo` "1:2:3:4:5:6:7::"+ -- works with only first or last:+ "::2:3:4:5:6:7:8" `roundTripsTo` "0:2:3:4:5:6:7:8"+ "1:2:3:4:5:6:7::" `roundTripsTo` "1:2:3:4:5:6:7:0" - where- roundTripsTo s sExpected =- case AT.parseOnly (IPv6Text.parser <* AT.endOfInput) (Text.pack s) of- Right result -> IPv6Text.encode result @?= Text.pack sExpected- Left failMsg -> fail failMsg -- parse shouldn't fail here+ -- decimal notation in IPv6 addresses:+ "1:2:3:4:5:6:0.7.0.8" `roundTripsTo` "1:2:3:4:5:6:7:8"+ "::0.0.0.0" `roundTripsTo` "::" + -- per https://tools.ietf.org/html/rfc5952#section-5+ "::ffff:0:0" `roundTripsTo` "::ffff:0.0.0.0"+ "::ffff:00ff:ff00" `roundTripsTo` "::ffff:0.255.255.0"+ "::ffff:203.0.113.17" `roundTripsTo` "::ffff:203.0.113.17"+ "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 -> enc result @?= Text.pack sExpected+ Left failMsg -> fail ("failed to parse '" ++ s ++ "': " ++ failMsg)+ textBadIPv4 :: [String] textBadIPv4 = [ "122.256.0.0"@@ -248,54 +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 ++ "]") $ IPv4Text.decode (Text.pack str) @?= Nothing+ PH.testCase ("Should fail to decode [" ++ str ++ "]") $ IPv4.decode (Text.pack str) @?= Nothing testMacEncode :: Assertion-testMacEncode = MacText.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 { getHexMac :: Mac }+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 { getHexIPv6 :: IPv6 }+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 -newtype Hex a = Hex { getHex :: a }+deriving instance Arbitrary IPv4 --- instance (Integral a, Show a) => Show (Hex a) where--- show = showHex . getHex+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)+ ] +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+ ]++instance Arbitrary Mac where+ 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)++instance Arbitrary IPv6Range where+ arbitrary = IPv6.range <$> arbitrary <*> choose (0, 128)+ shrink (IPv6Range addr mask) =+ liftA2+ IPv6.range+ (shrink addr)+ (filter (/= mask) [0, div mask 2, if mask > 0 then mask - 1 else 0])++instance Arbitrary MacCodec where+ arbitrary = MacCodec <$> arbitrary <*> arbitrary++instance Arbitrary MacGrouping where+ arbitrary =+ oneof+ [ MacGroupingPairs <$> arbitraryMacSeparator+ , MacGroupingTriples <$> arbitraryMacSeparator+ , MacGroupingQuadruples <$> arbitraryMacSeparator+ , pure MacGroupingNoSeparator+ ]++arbitraryMacSeparator :: Gen Char+arbitraryMacSeparator = elements [':', '-', '.', '_']++byteStringToBytes :: BC8.ByteString -> Bytes+byteStringToBytes = Ascii.fromString . BC8.unpack