diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +[![Hackage](https://img.shields.io/hackage/v/ip.svg)](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.) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/ip.cabal b/ip.cabal --- a/ip.cabal +++ b/ip.cabal @@ -1,15 +1,16 @@ -cabal-version: 2.2 -name: ip -version: 1.7.7 -synopsis: Library for IP and MAC addresses -homepage: https://github.com/andrewthad/haskell-ip#readme -license: BSD-3-Clause -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2016 Andrew Martin -category: web -build-type: Simple +cabal-version: 3.0 +name: ip +version: 1.7.8 +synopsis: Library for IP and MAC addresses +homepage: https://github.com/byteverse/haskell-ip +bug-reports: https://github.com/byteverse/haskell-ip/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2016 Andrew Martin +category: web +build-type: Simple description: The `ip` package provides types and functions for dealing with IPv4 addresses, CIDR blocks, and MAC addresses. We provide instances @@ -29,16 +30,29 @@ The following packages are intended to be used with this package: . * `yesod-ip`: Provides orphan instances needed to work with yesod and - persistent. Also, provides a `yesod-form` helper. + persistent. Also, provides a `yesod-form` helper. +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 + +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + library - hs-source-dirs: src + import: build-settings + hs-source-dirs: src + ghc-options: -O2 exposed-modules: Net.IP Net.IPv4 Net.IPv6 Net.Mac Net.Types + other-modules: Data.ByteString.Builder.Fixed Data.Text.Builder.Common.Compat @@ -46,70 +60,71 @@ Data.Text.Builder.Fixed Data.Text.Builder.Variable Data.Word.Synthetic.Word12 + build-depends: - , aeson >= 1.0 && < 2.2 - , attoparsec >= 0.13 && < 0.15 - , base >= 4.9 && < 5 - , byteslice >= 0.1.2 && < 0.3 - , bytesmith >= 0.3.9 && < 0.4 - , bytestring >= 0.10.8 && < 0.12 - , deepseq >= 1.4 && < 1.5 - , hashable >= 1.2 && < 1.5 - , natural-arithmetic >= 0.1 && <0.3 - , primitive >= 0.6.4 && < 0.10 - , bytebuild >= 0.3.4 && <0.4 - , text >= 1.2 && < 2.1 - , text-short >= 0.1.3 && < 0.2 - , vector >= 0.11 && < 0.14 - , wide-word >= 0.1.1.2 && < 0.2 - , word-compat >= 0.0.4 && <0.1 - 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: - , HUnit - , QuickCheck , attoparsec , base , byteslice , bytestring + , HUnit , ip - , quickcheck-classes >= 0.4.13 && < 0.7.0.0 + , QuickCheck + , quickcheck-classes >=0.4.13 && <0.7.0.0 , tasty , tasty-hunit , tasty-quickcheck , text , text-short , wide-word + other-modules: IPv4ByteString1 IPv4Text1 IPv4Text2 Naive - ghc-options: -Wall -O2 - default-language: Haskell2010 test-suite spec - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs + import: build-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs build-depends: , base - , hspec >= 2.5.5 + , hspec >=2.5.5 , ip - , wide-word - other-modules: - Net.IPv4Spec - ghc-options: -Wall -O2 - default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 + 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: , attoparsec , base @@ -118,8 +133,9 @@ , criterion , ip , primitive - , text , random + , text + other-modules: IPv4ByteString1 IPv4DecodeText1 @@ -127,12 +143,7 @@ IPv4Text1 IPv4Text2 Naive - ghc-options: -Wall -O2 - default-language: Haskell2010 - hs-source-dirs: test - main-is: Bench.hs source-repository head - type: git - location: https://github.com/andrewthad/haskell-ip - + type: git + location: git://github.com/byteverse/haskell-ip.git diff --git a/src/Data/ByteString/Builder/Fixed.hs b/src/Data/ByteString/Builder/Fixed.hs --- a/src/Data/ByteString/Builder/Fixed.hs +++ b/src/Data/ByteString/Builder/Fixed.hs @@ -4,10 +4,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# 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@. -} @@ -27,14 +26,14 @@ #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif -import Data.Word -import Data.Word.Synthetic.Word12 (Word12) import Data.Bits +import Data.ByteString.Internal (ByteString (..)) +import Data.ByteString.Short (ShortByteString) import Data.Char (ord) -import Text.Printf -import Data.ByteString.Internal (ByteString(..)) +import Data.Word +import Data.Word.Synthetic.Word12 (Word12) import Foreign -import Data.ByteString.Short (ShortByteString) +import Text.Printf import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as BC8 @@ -109,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 @@ -137,12 +136,12 @@ 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 @@ -153,8 +152,9 @@ word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w {-# INLINE word8 #-} --- | Taken from @Data.ByteString.Internal@. The same warnings --- apply here. +{- | Taken from @Data.ByteString.Internal@. The same warnings + apply here. +-} c2w :: Char -> Word8 c2w = fromIntegral . ord {-# INLINE c2w #-} diff --git a/src/Data/Text/Builder/Common/Compat.hs b/src/Data/Text/Builder/Common/Compat.hs --- a/src/Data/Text/Builder/Common/Compat.hs +++ b/src/Data/Text/Builder/Common/Compat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + {- | Compatibility module allowing us to support UTF-16 & UTF-8 versions of the 'text' package. -} diff --git a/src/Data/Text/Builder/Common/Internal.hs b/src/Data/Text/Builder/Common/Internal.hs --- a/src/Data/Text/Builder/Common/Internal.hs +++ b/src/Data/Text/Builder/Common/Internal.hs @@ -1,29 +1,31 @@ module Data.Text.Builder.Common.Internal where -import Data.Text (Text) import Control.Monad.ST -import Data.Monoid -import Text.Printf import Data.Char (ord) import Data.Foldable (fold) +import Data.Monoid +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Array as A import qualified Data.Text.Internal.Unsafe.Char as TC +import Text.Printf --- | This is slower that just pattern matching on the Text data constructor. --- However, it will work with GHCJS. This should only be used in places --- where we know that it will only be evaluated once. +{- | This is slower that just pattern matching on the Text data constructor. + However, it will work with GHCJS. This should only be used in places + where we know that it will only be evaluated once. +-} portableTextArray :: Text -> A.Array portableTextArray = fst . portableUntext {-# INLINE portableTextArray #-} --- | This length is not the character length. It is the length of Word16s --- required by a UTF16 representation. +{- | This length is not the character length. It is the length of Word16s + required by a UTF16 representation. +-} portableTextLength :: Text -> Int portableTextLength = snd . portableUntext {-# INLINE portableTextLength #-} -portableUntext :: Text -> (A.Array,Int) +portableUntext :: Text -> (A.Array, Int) portableUntext t = let str = Text.unpack t Sum len = foldMap (Sum . charUtf16Size) str @@ -31,11 +33,12 @@ marr <- A.new len writeString marr str return marr - in (arr,len) + in (arr, len) {-# NOINLINE portableUntext #-} writeString :: A.MArray s -> String -> ST s () -writeString marr = go 0 where +writeString marr = go 0 + where go i s = case s of c : cs -> do n <- TC.unsafeWrite marr i c @@ -46,32 +49,41 @@ charUtf16Size c = if ord c < 0x10000 then 1 else 2 hexValuesWord12Upper :: A.Array -hexValuesWord12Upper = portableTextArray $ fold - $ map (Text.pack . printf "%03X") [0 :: Int ..4096] +hexValuesWord12Upper = + portableTextArray $ + fold $ + map (Text.pack . printf "%03X") [0 :: Int .. 4096] {-# NOINLINE hexValuesWord12Upper #-} hexValuesWord12Lower :: A.Array -hexValuesWord12Lower = portableTextArray $ fold - $ map (Text.pack . printf "%03x") [0 :: Int ..4096] +hexValuesWord12Lower = + portableTextArray $ + fold $ + map (Text.pack . printf "%03x") [0 :: Int .. 4096] {-# NOINLINE hexValuesWord12Lower #-} hexValuesWord8Upper :: A.Array -hexValuesWord8Upper = portableTextArray $ fold - $ map (Text.pack . printf "%02X") [0 :: Int ..255] +hexValuesWord8Upper = + portableTextArray $ + fold $ + map (Text.pack . printf "%02X") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Upper #-} hexValuesWord8Lower :: A.Array -hexValuesWord8Lower = portableTextArray $ fold - $ map (Text.pack . printf "%02x") [0 :: Int ..255] +hexValuesWord8Lower = + portableTextArray $ + fold $ + map (Text.pack . printf "%02x") [0 :: Int .. 255] {-# NOINLINE hexValuesWord8Lower #-} twoDecimalDigits :: A.Array -twoDecimalDigits = portableTextArray - $ foldMap (Text.pack . printf "%02d") [0 :: Int ..99] +twoDecimalDigits = + portableTextArray $ + foldMap (Text.pack . printf "%02d") [0 :: Int .. 99] {-# NOINLINE twoDecimalDigits #-} threeDecimalDigits :: A.Array -threeDecimalDigits = portableTextArray - $ foldMap (Text.pack . printf "%03d") [0 :: Int ..255] +threeDecimalDigits = + portableTextArray $ + foldMap (Text.pack . printf "%03d") [0 :: Int .. 255] {-# NOINLINE threeDecimalDigits #-} - diff --git a/src/Data/Text/Builder/Fixed.hs b/src/Data/Text/Builder/Fixed.hs --- a/src/Data/Text/Builder/Fixed.hs +++ b/src/Data/Text/Builder/Fixed.hs @@ -1,12 +1,11 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -funbox-strict-fields #-} -{-| For concatenating fixed-width strings that are only a few +{- | For concatenating fixed-width strings that are only a few characters each, this can be ten times faster than the builder that ships with @text@. -} @@ -28,14 +27,14 @@ #endif import Data.Bits import Data.Char (ord) -import Data.Word -import Data.Word.Synthetic.Word12 (Word12) -import Data.Text (Text) import qualified Data.Semigroup as Semigroup +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Array as A -import qualified Data.Text.Internal as TI import qualified Data.Text.Builder.Common.Internal as I +import qualified Data.Text.Internal as TI +import Data.Word +import Data.Word.Synthetic.Word12 (Word12) data Builder a where BuilderStatic :: Text -> Builder a @@ -75,6 +74,7 @@ BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b)) {-# INLINE contramapBuilder #-} +{- FOURMOLU_DISABLE -} run :: Builder a -> a -> Text run x = case x of BuilderStatic t -> \_ -> t @@ -92,6 +92,7 @@ A.unsafeFreeze marr in TI.text outArr 0 len {-# INLINE run #-} +{- FOURMOLU_ENABLE -} word8HexFixedUpper :: Builder Word8 word8HexFixedUpper = word8HexFixedGeneral True @@ -112,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)) @@ -138,4 +140,3 @@ word12HexFixedLower :: Builder Word12 word12HexFixedLower = word12HexFixedGeneral False {-# INLINE word12HexFixedLower #-} - diff --git a/src/Data/Text/Builder/Variable.hs b/src/Data/Text/Builder/Variable.hs --- a/src/Data/Text/Builder/Variable.hs +++ b/src/Data/Text/Builder/Variable.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# 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, @@ -23,18 +23,18 @@ , word8 ) where -import Data.Word -import Data.Text (Text) -import Data.Text.Builder.Common.Compat (Codepoint) import Control.Monad.ST import Data.Char (ord) -import Data.Vector (Vector) import Data.Maybe (fromMaybe) -import qualified Data.Vector as Vector import qualified Data.Semigroup as Semigroup +import Data.Text (Text) import qualified Data.Text.Array as A +import Data.Text.Builder.Common.Compat (Codepoint) import qualified Data.Text.Builder.Common.Internal as I import qualified Data.Text.Internal as TI +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Word data Builder a = Builder @@ -60,10 +60,10 @@ run :: Builder a -> a -> Text run (Builder maxLen f) = \a -> - let (outArr,len) = A.run2 $ do + let (outArr, len) = A.run2 $ do marr <- A.new maxLen finalIx <- f 0 marr a - return (marr,finalIx) + return (marr, finalIx) in TI.text outArr 0 len {-# INLINE run #-} @@ -90,25 +90,27 @@ {-# INLINE staticCharBmp #-} word8 :: Builder Word8 -word8 = Builder 3 $ \pos marr w -> if - | w < 10 -> do - A.unsafeWrite marr pos (i2w w) - return (pos + 1) - | w < 100 -> do - let wInt = fromIntegral w - ix = wInt + wInt - A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix) - A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1)) - return (pos + 2) - | otherwise -> do - let wInt = fromIntegral w - ix = wInt + wInt + wInt - A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix) - A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1)) - A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2)) - return (pos + 3) +word8 = Builder 3 $ \pos marr w -> + if + | w < 10 -> do + A.unsafeWrite marr pos (i2w w) + return (pos + 1) + | w < 100 -> do + let wInt = fromIntegral w + ix = wInt + wInt + A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix) + A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1)) + return (pos + 2) + | otherwise -> do + let wInt = fromIntegral w + ix = wInt + wInt + wInt + A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix) + A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1)) + A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2)) + return (pos + 3) {-# INLINE word8 #-} +{- FOURMOLU_DISABLE -} -- This has not yet been tested. _vector :: Text -- ^ Default, used when index is out of range @@ -133,8 +135,8 @@ i2w :: Integral a => a -> Codepoint i2w v = asciiZero + fromIntegral v {-# INLINE i2w #-} +{- FOURMOLU_ENABLE -} asciiZero :: Codepoint asciiZero = 48 {-# INLINE asciiZero #-} - diff --git a/src/Data/Word/Synthetic/Word12.hs b/src/Data/Word/Synthetic/Word12.hs --- a/src/Data/Word/Synthetic/Word12.hs +++ b/src/Data/Word/Synthetic/Word12.hs @@ -1,48 +1,47 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- Module : Data.Word.Word12 --- License : see src/Data/LICENSE --- Stability : experimental --- Portability : non-portable (GHC Extensions) - -- Provide a 12-bit unsigned integral type: 'Word12', analagous to Word8, -- Word16, etc. -- -module Data.Word.Synthetic.Word12 ( - -- * Word12 type - Word12(..) - -- * Internal helpers +{- | +Module : Data.Word.Word12 +License : see src/Data/LICENSE +Stability : experimental +Portability : non-portable (GHC Extensions) +-} +module Data.Word.Synthetic.Word12 + ( -- * Word12 type + Word12 (..) + + -- * Internal helpers , narrow12Word# , clz12# , ctz12# , popCnt12# ) - where -import Data.Bits -import Data.Data -import Data.Maybe +import Data.Bits +import Data.Data +import Data.Maybe -import GHC.Arr -import GHC.Base -import GHC.Enum +import GHC.Arr +import GHC.Base +import GHC.Enum #if MIN_VERSION_base(4,15,0) import GHC.Integer (integerToWord, smallInteger) import GHC.Num hiding (integerToWord) #else import GHC.Num #endif -import GHC.Read -import GHC.Real -import GHC.Show +import GHC.Read +import GHC.Real +import GHC.Show import qualified GHC.Word.Compat as Compat @@ -52,7 +51,6 @@ -- 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 @@ -61,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. @@ -71,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#) @@ -92,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 = \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#) +"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) #-} - - diff --git a/src/Net/IP.hs b/src/Net/IP.hs --- a/src/Net/IP.hs +++ b/src/Net/IP.hs @@ -1,13 +1,12 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - {-# OPTIONS_GHC -Wall #-} -{-| An IP data type representing either an IPv4 address or +{- | An IP data type representing either an IPv4 address or an IPv6 address. The user can think of this as though it were a sum type. However, to minimize indirections, it is actually implemented as an 'IPv6' address, with 'IPv4' @@ -30,91 +29,108 @@ >>> decode "A3F5:12:F26::1466:8B91" Just (ipv6 0xa3f5 0x0012 0x0f26 0x0000 0x0000 0x0000 0x1466 0x8b91) -} - module Net.IP ( -- * Pattern Matching case_ , isIPv4 , isIPv6 + -- * Construction , ipv4 , ipv6 , fromIPv4 , fromIPv6 + -- * Textual Conversion + -- ** Text , encode , encodeShort , decode , decodeShort , boundedBuilderUtf8 + -- ** Bytes , decodeUtf8Bytes , parserUtf8Bytes + -- ** Printing , print + -- * Types - , IP(..) + , IP (..) ) where import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON(..),ToJSON(..)) +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bits import Data.Coerce (coerce) import Data.Data (Data) import Data.Hashable (Hashable) import Data.Ix (Ix) import Data.Text (Text) -import Data.WideWord (Word128(..)) -import Data.Word (Word8,Word16) +import Data.Text.Short (ShortText) +import Data.WideWord (Word128 (..)) +import Data.Word (Word16, Word8) import GHC.Generics (Generic) -import Net.IPv4 (IPv4(..)) -import Net.IPv6 (IPv6(..)) -import Prelude hiding (print) +import Net.IPv4 (IPv4 (..)) +import Net.IPv6 (IPv6 (..)) import Text.ParserCombinators.ReadPrec ((+++)) -import Text.Read (Read(..)) -import Data.Text.Short (ShortText) +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.Text.IO as TIO 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 +{- $setup +>>> :set -XOverloadedStrings +>>> import qualified Arithmetic.Nat as Nat +-} --- | Run a function over an 'IP' depending on its status --- as an 'IPv4' or 'IPv6'. --- --- >>> case_ IPv4.encode IPv6.encode (ipv4 192 168 2 47) --- "192.168.2.47" --- --- >>> addr = ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001 --- >>> case_ IPv4.encode IPv6.encode addr --- "2001:db8::1" +{- | Run a function over an 'IP' depending on its status + as an 'IPv4' or 'IPv6'. + + >>> case_ IPv4.encode IPv6.encode (ipv4 192 168 2 47) + "192.168.2.47" + + >>> addr = ipv6 0x2001 0x0db8 0x0000 0x0000 0x0000 0x0000 0x0000 0x0001 + >>> case_ IPv4.encode IPv6.encode addr + "2001:db8::1" +-} case_ :: (IPv4 -> a) -> (IPv6 -> a) -> IP -> a -- Note: rather than performing the masking operations on the 'Word128', -- we unwrap the 'Word64's, as that's probably a bit more efficient, and -- we might need the lower word anyway. -case_ f g (IP addr@(IPv6 (Word128 w1 w2))) = if w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000) - then f (IPv4 (fromIntegral w2)) - else g addr +case_ f g (IP addr@(IPv6 (Word128 w1 w2))) = + if w1 == 0 && (0xFFFFFFFF00000000 .&. w2 == 0x0000FFFF00000000) + then f (IPv4 (fromIntegral w2)) + else g addr --- | Construct an 'IP' address from the four octets of --- an IPv4 address. +{- | Construct an 'IP' address from the four octets of + an IPv4 address. +-} ipv4 :: Word8 -> Word8 -> Word8 -> Word8 -> IP ipv4 a b c d = fromIPv4 (IPv4.fromOctets a b c d) --- | Construct an 'IP' address from the eight 16-bit --- chunks of an IPv6 address. -ipv6 :: Word16 -> Word16 -> Word16 -> Word16 - -> Word16 -> Word16 -> Word16 -> Word16 - -> IP +{- | Construct an 'IP' address from the eight 16-bit + chunks of an IPv6 address. +-} +ipv6 :: + Word16 -> + Word16 -> + Word16 -> + Word16 -> + Word16 -> + Word16 -> + Word16 -> + Word16 -> + IP ipv6 a b c d e f g h = fromIPv6 (IPv6.fromWord16s a b c d e f g h) -- | Turn an 'IPv4' into an 'IP'. @@ -125,48 +141,53 @@ fromIPv6 :: IPv6 -> IP fromIPv6 = IP --- | Encode an 'IP' as 'Text'. --- --- >>> encode (ipv4 10 0 0 25) --- "10.0.0.25" --- --- >>> encode (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) --- "3124::dead:cafe:ff:fe00:1" +{- | Encode an 'IP' as 'Text'. + + >>> encode (ipv4 10 0 0 25) + "10.0.0.25" + + >>> encode (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) + "3124::dead:cafe:ff:fe00:1" +-} encode :: IP -> Text encode = case_ IPv4.encode IPv6.encode --- | 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" +{- | 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] +{- | 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 +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 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 @@ -174,12 +195,13 @@ 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) +{- | 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) @@ -197,49 +219,52 @@ parserUtf8Bytes :: e -> Parser.Parser e s IP parserUtf8Bytes e = fmap fromIPv4 (IPv4.parserUtf8Bytes ()) - `Parser.orElse` - coerce (IPv6.parserUtf8Bytes e) + `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 +{- | Is the 'IP' an IPv4 address? + + >>> isIPv4 (ipv4 10 0 0 25) + True + + >>> isIPv4 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) + False +-} isIPv4 :: IP -> Bool isIPv4 = case_ (const True) (const False) -{-# inline isIPv4 #-} +{-# INLINE isIPv4 #-} --- | Is the 'IP' an IPv6 address? --- --- >>> isIPv6 (ipv4 10 0 0 25) --- False --- --- >>> isIPv6 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) --- True +{- | Is the 'IP' an IPv6 address? + + >>> isIPv6 (ipv4 10 0 0 25) + False + + >>> isIPv6 (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) + True +-} isIPv6 :: IP -> Bool isIPv6 = case_ (const False) (const True) -{-# inline isIPv6 #-} +{-# INLINE isIPv6 #-} --- | Print an 'IP' using the textual encoding. This exists mostly for --- debugging purposes. --- --- >>> print (ipv4 10 0 0 25) --- 10.0.0.25 --- --- >>> print (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) --- 3124::dead:cafe:ff:fe00:1 +{- | Print an 'IP' using the textual encoding. This exists mostly for + debugging purposes. + + >>> print (ipv4 10 0 0 25) + 10.0.0.25 + + >>> print (ipv6 0x3124 0x0 0x0 0xDEAD 0xCAFE 0xFF 0xFE00 0x1) + 3124::dead:cafe:ff:fe00:1 +-} print :: IP -> IO () print = TIO.putStrLn . encode --- | A 32-bit 'IPv4' address or a 128-bit 'IPv6' address. Internally, this --- is just represented as an 'IPv6' address. The functions provided --- in @Net.IP@ help simulate constructing and pattern matching on values --- of this type. All functions and typeclass methods that convert --- 'IP' values to text will display it as an 'IPv4' address if possible. -newtype IP = IP { getIP :: IPv6 } - deriving stock (Eq,Ord,Generic,Ix,Data) +{- | 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 @@ -257,4 +282,3 @@ parseJSON = Aeson.withText "IP" $ \t -> case decode t of Nothing -> fail "Could not parse IP address" Just addr -> return addr - diff --git a/src/Net/IPv4.hs b/src/Net/IPv4.hs --- a/src/Net/IPv4.hs +++ b/src/Net/IPv4.hs @@ -1,1368 +1,1449 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} - -{-| This module provides the IPv4 data type and functions for working - with it. --} - -module Net.IPv4 - ( -- * Conversion Functions - ipv4 - , fromOctets - , fromTupleOctets - , toOctets - -- * Special IP Addresses - , any - , loopback - , localhost - , broadcast - -- * Range Predicates - , private - , reserved - , public - -- * Textual Conversion - -- ** Text - , encode - , decode - , builder - , reader - , parser - , 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(..),ToJSON(..)) -import Data.Aeson (ToJSONKey(..),FromJSONKey(..),ToJSONKeyFunction(..),FromJSONKeyFunction(..)) -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 Prelude hiding (any, print, print) -import Text.ParserCombinators.ReadPrec (prec,step) -import Text.Printf (printf) -import Text.Read (Read(..),Lexeme(Ident),lexP,parens) - -import qualified 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.Bytes.Builder.Bounded as BB -import qualified Data.Bytes.Builder as UB -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.ByteString.Internal as I -import qualified Data.ByteString.Unsafe as ByteString -import qualified Data.ByteString.Short.Internal as BSS -import qualified Data.Bytes as Bytes -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 - -toTextPreallocatedPartTwo :: Word -> Word -> Word -> Word -> Text -toTextPreallocatedPartTwo !w1 !w2 !w3 !w4 = -#ifdef ghcjs_HOST_OS - let dotStr = "." - in Text.pack $ concat - [ show w1 - , "." - , show w2 - , "." - , show w3 - , "." - , show w4 - ] -#else - let dot = 46 - (arr,len) = runST $ do - marr <- TArray.new 15 - i1 <- putAndCount 0 w1 marr - let n1 = i1 - n1' = i1 + 1 - TArray.unsafeWrite marr n1 dot - i2 <- putAndCount n1' w2 marr - let n2 = i2 + n1' - n2' = n2 + 1 - TArray.unsafeWrite marr n2 dot - i3 <- putAndCount n2' w3 marr - let n3 = i3 + n2' - n3' = n3 + 1 - TArray.unsafeWrite marr n3 dot - i4 <- putAndCount n3' w4 marr - theArr <- TArray.unsafeFreeze marr - return (theArr,i4 + n3') - in Text arr 0 len -#endif - -twoDigits :: ByteString -twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99 -{-# NOINLINE twoDigits #-} - -threeDigits :: ByteString -threeDigits = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 999 -{-# NOINLINE threeDigits #-} - -i2w :: Integral a => a -> 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 @@ 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 . -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 - +{-# 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 @@ 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 . +-} +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 diff --git a/src/Net/IPv6.hs b/src/Net/IPv6.hs --- a/src/Net/IPv6.hs +++ b/src/Net/IPv6.hs @@ -8,963 +8,1071 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} - -{-| This module provides the IPv6 data type and functions for working - with it. --} -module Net.IPv6 - ( -- * Convert - ipv6 - , fromOctets - , fromWord16s - , fromWord32s - , fromTupleWord16s - , fromTupleWord32s - , toWord16s - , toWord32s - -- * Special IP Addresses - , any - , loopback - , localhost - -- * Textual Conversion - -- ** Text - , encode - , 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.Ix (Ix) -import Data.Hashable (Hashable,hashWithSalt) -import Data.List (intercalate, group) -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#,Word#,Int(I#)) -import GHC.Generics (Generic) -import Numeric (showHex) -import Text.ParserCombinators.ReadPrec (prec,step) -import Text.Read (Read(..),Lexeme(Ident),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.Bytes.Builder.Bounded as BB -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Parser as Parser -import qualified Data.Bytes.Parser.Latin as Latin -import qualified Data.ByteString.Short.Internal as BSS -import qualified Data.Primitive as PM -import qualified Data.Text as Text -import qualified Data.Text.IO as TIO -import qualified Data.Text.Short.Unsafe as TS -import qualified Data.Text.Short 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 , --- 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 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 - -- This representation is RECOMMENDED by https://tools.ietf.org/html/rfc5952#section-5 - then - Text.pack "::ffff:" - `mappend` - IPv4.encode (IPv4.IPv4 (fromIntegral w7 `unsafeShiftL` 16 .|. fromIntegral w8)) - else toText [w1, w2, w3, w4, w5, w6, w7, w8] - where - (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 - -- start is inclusive. end is exclusive - in 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 , --- 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 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 +{-# 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 , +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 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 , +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 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)) diff --git a/src/Net/Mac.hs b/src/Net/Mac.hs --- a/src/Net/Mac.hs +++ b/src/Net/Mac.hs @@ -13,7 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -{-| This module provides the Mac data type and functions for working +{- | This module provides the Mac data type and functions for working with it. -} module Net.Mac @@ -21,7 +21,9 @@ mac , fromOctets , toOctets + -- * Textual Conversion + -- ** Text , encode , encodeWith @@ -30,8 +32,10 @@ , builder , parser , parserWith + -- ** ShortText , encodeShort + -- ** UTF-8 ByteString , encodeUtf8 , encodeWithUtf8 @@ -40,38 +44,41 @@ , builderUtf8 , parserUtf8 , parserWithUtf8 + -- ** ByteString , decodeBytes , decodeOctets + -- ** UTF-8 Bytes , boundedBuilderUtf8 , decodeUtf8Bytes , parserUtf8Bytes + -- ** Printing , print + -- * Default Codec , defCodec + -- * Types - , Mac(..) - , MacCodec(..) - , MacGrouping(..) + , Mac (..) + , MacCodec (..) + , MacGrouping (..) ) where import Prelude hiding (print) import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON(..),ToJSON(..)) -import Data.Aeson (ToJSONKey(..),FromJSONKey(..)) -import Data.Aeson (ToJSONKeyFunction(..),FromJSONKeyFunction(..)) -import Data.Bits ((.|.),unsafeShiftL,unsafeShiftR,(.&.)) +import Data.Aeson (FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..)) +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) import Data.ByteString (ByteString) -import Data.ByteString.Short.Internal (ShortByteString(SBS)) -import Data.Char (ord,chr) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import Data.Char (chr, ord) import Data.Data (Data) import Data.Hashable (Hashable) import Data.Ix (Ix) -import Data.Primitive.ByteArray (ByteArray(ByteArray)) -import Data.Primitive.Types (Prim(..)) +import Data.Primitive.ByteArray (ByteArray (ByteArray)) +import Data.Primitive.Types (Prim (..)) import Data.Text (Text) import Data.Text.Short (ShortText) import Data.Word @@ -79,8 +86,8 @@ import GHC.Enum (predError, succError) import GHC.Exts import GHC.Generics (Generic) -import Text.ParserCombinators.ReadPrec (prec,step) -import Text.Read (Read(..),Lexeme(Ident),lexP,parens) +import Text.ParserCombinators.ReadPrec (prec, step) +import Text.Read (Lexeme (Ident), Read (..), lexP, parens) import qualified Arithmetic.Nat as Nat import qualified Data.Aeson as Aeson @@ -88,19 +95,19 @@ import qualified Data.Attoparsec.ByteString as AB import qualified Data.Attoparsec.ByteString as ABW import qualified Data.Attoparsec.Text as AT -import qualified Data.Bytes.Builder.Bounded as BBB -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Parser as Parser -import qualified Data.Bytes.Parser.Latin as Latin 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 Data.Text as Text () import qualified GHC.Prim.Compat as Compat import qualified GHC.Word.Compat as Compat @@ -108,51 +115,60 @@ 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. +{- | 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 stock (Eq, Ord, Generic, Ix, Data) deriving newtype (Hashable) instance NFData Mac +{- $setup --- $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 } +These are here to get doctest's property checking to work --- | Construct a 'Mac' address from a 'Word64'. Only the lower --- 48 bits are used. +>>> :set -XOverloadedStrings +>>> import Test.QuickCheck (Arbitrary(..),CoArbitrary(..),coarbitraryEnum) +>>> import qualified Data.Text as Text (pack) +>>> import qualified Data.Text.IO as T +>>> import qualified Data.ByteString.Char8 as BC +>>> import qualified Data.ByteString as B +>>> import qualified Data.Bytes.Text.Ascii as Ascii +>>> import qualified Net.Mac as Mac +>>> import qualified Arithmetic.Nat as Nat +>>> import qualified Data.Attoparsec.Text as AT +>>> import qualified Data.Bytes.Builder.Bounded as BBB +>>> import Net.Mac (Mac(Mac)) +>>> instance Arbitrary Mac where { arbitrary = fmap (Mac . (0xFFFFFFFFFFFF .&.)) arbitrary } +>>> instance CoArbitrary Mac where { coarbitrary = coarbitraryEnum } +-} + +{- | Construct a 'Mac' address from a 'Word64'. Only the lower + 48 bits are used. +-} mac :: Word64 -> Mac mac w = Mac (w .&. 0xFFFFFFFFFFFF) -- | Create a 'Mac' address from six octets. fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac -fromOctets a b c d e f = Mac $ unsafeWord48FromOctets - (fromIntegral a) (fromIntegral b) (fromIntegral c) - (fromIntegral d) (fromIntegral e) (fromIntegral f) +fromOctets a b c d e f = + Mac $ + unsafeWord48FromOctets + (fromIntegral a) + (fromIntegral b) + (fromIntegral c) + (fromIntegral d) + (fromIntegral e) + (fromIntegral f) --- | Convert a 'Mac' address to the six octets that make it up. --- This function and 'fromOctets' are inverses: --- --- prop> m == (let (a,b,c,d,e,f) = Mac.toOctets m in Mac.fromOctets a b c d e f) -toOctets :: Mac -> (Word8,Word8,Word8,Word8,Word8,Word8) +{- | Convert a 'Mac' address to the six octets that make it up. + This function and 'fromOctets' are inverses: + + prop> m == (let (a,b,c,d,e,f) = Mac.toOctets m in Mac.fromOctets a b c d e f) +-} +toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8) toOctets (Mac w) = ( fromIntegral $ unsafeShiftR w 40 , fromIntegral $ unsafeShiftR w 32 @@ -162,35 +178,40 @@ , fromIntegral w ) --- | This function is deprecated. It will be renamed in a future release --- since the name is misleading. +{- | 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. +{- | 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 +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 @@ -198,21 +219,23 @@ 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 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 +{- | 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 @@ -221,7 +244,7 @@ MacGroupingPairs c -> case u of True -> TFB.run (fixedBuilderPairs TFB.word8HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderPairs TFB.word8HexFixedLower) (Pair c m) - -- withCasedBuilder u $ \bw8 -> TFB.run (fixedBuilderPairs bw8) (Pair c m) + -- withCasedBuilder u $ \bw8 -> TFB.run (fixedBuilderPairs bw8) (Pair c m) MacGroupingTriples c -> case u of True -> TFB.run (fixedBuilderTriples TFB.word12HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderTriples TFB.word12HexFixedLower) (Pair c m) @@ -229,23 +252,25 @@ True -> TFB.run (fixedBuilderQuadruples TFB.word8HexFixedUpper) (Pair c m) False -> TFB.run (fixedBuilderQuadruples TFB.word8HexFixedLower) (Pair c m) --- | Decode a 'Mac' address using the default 'MacCodec' 'defCodec'. --- --- >>> Mac.decode (Text.pack "a4:7f:24:7a:b4:23") --- Just (mac 0xa47f247ab423) --- --- >>> Mac.decode (Text.pack "a47-f24-7ab-423") --- Nothing +{- | Decode a 'Mac' address using the default 'MacCodec' 'defCodec'. + + >>> Mac.decode (Text.pack "a4:7f:24:7a:b4:23") + Just (mac 0xa47f247ab423) + + >>> Mac.decode (Text.pack "a47-f24-7ab-423") + Nothing +-} decode :: Text -> Maybe Mac decode = decodeWith defCodec --- | Decode a 'Mac' address from 'Text' using the given 'MacCodec'. --- --- >>> 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) +{- | 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) @@ -253,25 +278,27 @@ 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" +{- | 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) +{- | 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 @@ -279,27 +306,40 @@ 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 +{- | The default 'MacCodec': all characters are lowercase hex, separated by colons into pairs. + + >>> T.putStrLn $ Mac.encodeWith Mac.defCodec (Mac 0xa47f247ab423) + a4:7f:24:7a:b4:23 +-} defCodec :: MacCodec defCodec = MacCodec (MacGroupingPairs ':') False parserQuadruples :: Char -> AT.Parser Mac -parserQuadruples s = fromOctets - <$> parseTwoHex <*> parseTwoHex <* AT.char s - <*> parseTwoHex <*> parseTwoHex <* AT.char s - <*> parseTwoHex <*> parseTwoHex +parserQuadruples s = + fromOctets + <$> parseTwoHex + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex + <*> parseTwoHex parserPairs :: Char -> AT.Parser Mac -parserPairs s = fromOctets - <$> parseTwoHex <* AT.char s - <*> parseTwoHex <* AT.char s - <*> parseTwoHex <* AT.char s - <*> parseTwoHex <* AT.char s - <*> parseTwoHex <* AT.char s - <*> parseTwoHex +parserPairs s = + fromOctets + <$> parseTwoHex + <* AT.char s + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex + <* AT.char s + <*> parseTwoHex parserTriples :: Char -> AT.Parser Mac parserTriples s = do @@ -318,22 +358,24 @@ a10 <- parseOneHex a11 <- parseOneHex a12 <- parseOneHex - return $ fromOctets - (unsafeShiftL a1 4 + a2) - (unsafeShiftL a3 4 + a4) - (unsafeShiftL a5 4 + a6) - (unsafeShiftL a7 4 + a8) - (unsafeShiftL a9 4 + a10) - (unsafeShiftL a11 4 + a12) + return $ + fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) parserNoSeparator :: AT.Parser Mac -parserNoSeparator = fromOctets - <$> parseTwoHex - <*> parseTwoHex - <*> parseTwoHex - <*> parseTwoHex - <*> parseTwoHex - <*> parseTwoHex +parserNoSeparator = + fromOctets + <$> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex parseTwoHex :: AT.Parser Word8 parseTwoHex = do @@ -347,7 +389,8 @@ | w >= 65 && w <= 70 = return (w - 55) | w >= 97 && w <= 102 = return (w - 87) | otherwise = a - where w = c2w c + where + w = c2w c parseOneHex :: AT.Parser Word8 parseOneHex = AT.anyChar >>= parseCharHex @@ -362,50 +405,50 @@ fixedBuilderTriples :: TFB.Builder Word12 -> TFB.Builder Pair fixedBuilderTriples tripBuilder = - TFB.contramapBuilder (word12At 36 . pairMac) tripBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word12At 24 . pairMac) tripBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word12At 12 . pairMac) tripBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word12At 0 . pairMac) tripBuilder + TFB.contramapBuilder (word12At 36 . pairMac) tripBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word12At 24 . pairMac) tripBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word12At 12 . pairMac) tripBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word12At 0 . pairMac) tripBuilder {-# INLINE fixedBuilderTriples #-} fixedBuilderNoSeparator :: TFB.Builder Word8 -> TFB.Builder Mac fixedBuilderNoSeparator hexBuilder = - TFB.contramapBuilder (word8At 40) hexBuilder - <> TFB.contramapBuilder (word8At 32) hexBuilder - <> TFB.contramapBuilder (word8At 24) hexBuilder - <> TFB.contramapBuilder (word8At 16) hexBuilder - <> TFB.contramapBuilder (word8At 8) hexBuilder - <> TFB.contramapBuilder (word8At 0) hexBuilder + TFB.contramapBuilder (word8At 40) hexBuilder + <> TFB.contramapBuilder (word8At 32) hexBuilder + <> TFB.contramapBuilder (word8At 24) hexBuilder + <> TFB.contramapBuilder (word8At 16) hexBuilder + <> TFB.contramapBuilder (word8At 8) hexBuilder + <> TFB.contramapBuilder (word8At 0) hexBuilder {-# INLINE fixedBuilderNoSeparator #-} fixedBuilderQuadruples :: TFB.Builder Word8 -> TFB.Builder Pair fixedBuilderQuadruples pairBuilder = - TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder - <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder - <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder - <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder + TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder {-# INLINE fixedBuilderQuadruples #-} fixedBuilderPairs :: TFB.Builder Word8 -> TFB.Builder Pair fixedBuilderPairs pairBuilder = - TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder - <> TFB.contramapBuilder pairSep TFB.charBmp - <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder + TFB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> TFB.contramapBuilder pairSep TFB.charBmp + <> TFB.contramapBuilder (word8At 0 . pairMac) pairBuilder {-# INLINE fixedBuilderPairs #-} word8At :: Int -> Mac -> Word8 @@ -416,92 +459,89 @@ 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 +{- | 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) +{- | 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) +{- | 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. +{- | 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] +{- | 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 + `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) +{- | 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}) +{- | 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 @@ -522,14 +562,16 @@ 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. +{- | Make a bytestring builder from a 'Mac' address + using a colon as the separator. +-} builderUtf8 :: Mac -> BB.Builder builderUtf8 = BB.byteString . encodeUtf8 --- | Lenient parser for a 'Mac' address using any character --- as the separator and accepting any digit grouping --- (i.e. @FA:43:B2:C0:0F:99@ or @A065.647B.87FA@). +{- | Lenient parser for a 'Mac' address using any character + as the separator and accepting any digit grouping + (i.e. @FA:43:B2:C0:0F:99@ or @A065.647B.87FA@). +-} parserUtf8 :: AB.Parser Mac parserUtf8 = parserLenientUtf8 @@ -555,32 +597,39 @@ a10 <- parseOneHexLenientUtf8 a11 <- parseOneHexLenientUtf8 a12 <- parseOneHexLenientUtf8 - return $ fromOctets - (unsafeShiftL a1 4 + a2) - (unsafeShiftL a3 4 + a4) - (unsafeShiftL a5 4 + a6) - (unsafeShiftL a7 4 + a8) - (unsafeShiftL a9 4 + a10) - (unsafeShiftL a11 4 + a12) - + return $ + fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) parserNoSeparatorUtf8 :: AB.Parser Mac -parserNoSeparatorUtf8 = fromOctets - <$> parseTwoHexUtf8 - <*> parseTwoHexUtf8 - <*> parseTwoHexUtf8 - <*> parseTwoHexUtf8 - <*> parseTwoHexUtf8 - <*> parseTwoHexUtf8 +parserNoSeparatorUtf8 = + fromOctets + <$> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 parserPairsUtf8 :: Word8 -> AB.Parser Mac -parserPairsUtf8 s = fromOctets - <$> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 +parserPairsUtf8 s = + fromOctets + <$> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 parserTriplesUtf8 :: Word8 -> AB.Parser Mac parserTriplesUtf8 s = do @@ -599,25 +648,33 @@ a10 <- parseOneHexUtf8 a11 <- parseOneHexUtf8 a12 <- parseOneHexUtf8 - return $ fromOctets - (unsafeShiftL a1 4 + a2) - (unsafeShiftL a3 4 + a4) - (unsafeShiftL a5 4 + a6) - (unsafeShiftL a7 4 + a8) - (unsafeShiftL a9 4 + a10) - (unsafeShiftL a11 4 + a12) + return $ + fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) parserQuadruplesUtf8 :: Word8 -> AB.Parser Mac -parserQuadruplesUtf8 s = fromOctets - <$> parseTwoHexUtf8 <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <*> parseTwoHexUtf8 <* ABW.word8 s - <*> parseTwoHexUtf8 <*> parseTwoHexUtf8 +parserQuadruplesUtf8 s = + fromOctets + <$> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 + <* ABW.word8 s + <*> parseTwoHexUtf8 + <*> parseTwoHexUtf8 parseOneHexUtf8 :: AB.Parser Word8 parseOneHexUtf8 = ABW.anyWord8 >>= parseWord8Hex --- | Parse a single hexidecimal character. This will skip --- at most one character to do this. +{- | Parse a single hexidecimal character. This will skip + at most one character to do this. +-} parseOneHexLenientUtf8 :: AB.Parser Word8 parseOneHexLenientUtf8 = do a <- ABW.anyWord8 @@ -631,9 +688,10 @@ b <- ABW.anyWord8 >>= parseWord8Hex return (unsafeShiftL a 4 + b) --- | Kind of a confusing type signature. The Word8 that stands --- alone represented an ascii-encoded value. The others actually --- describes the numbers that would be decoded from this value. +{- | Kind of a confusing type signature. The Word8 that stands + alone represented an ascii-encoded value. The others actually + describes the numbers that would be decoded from this value. +-} tryParseWord8Hex :: AB.Parser Word8 -> Word8 -> AB.Parser Word8 tryParseWord8Hex a w | w >= 48 && w <= 57 = return (w - 48) @@ -644,14 +702,15 @@ parseWord8Hex :: Word8 -> AB.Parser Word8 parseWord8Hex = tryParseWord8Hex (fail "invalid hexadecimal character") --- | Encode a 'Mac' address as a 'ByteString' using the given 'MacCodec'. --- --- >>> m = Mac 0xA47F247AB423 --- >>> BC.putStrLn $ 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 +{- | 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 @@ -660,7 +719,7 @@ MacGroupingPairs c -> case u of True -> BFB.run (fixedBuilderPairsUtf8 BFB.word8HexFixedUpper) (PairUtf8 (c2w c) m) False -> BFB.run (fixedBuilderPairsUtf8 BFB.word8HexFixedLower) (PairUtf8 (c2w c) m) - -- withCasedBuilder u $ \bw8 -> BFB.run (fixedBuilderPairs bw8) (Pair c m) + -- withCasedBuilder u $ \bw8 -> BFB.run (fixedBuilderPairs bw8) (Pair c m) MacGroupingTriples c -> case u of True -> BFB.run (fixedBuilderTriplesUtf8 BFB.word12HexFixedUpper) (PairUtf8 (c2w c) m) False -> BFB.run (fixedBuilderTriplesUtf8 BFB.word12HexFixedLower) (PairUtf8 (c2w c) m) @@ -675,50 +734,50 @@ fixedBuilderTriplesUtf8 :: BFB.Builder Word12 -> BFB.Builder PairUtf8 fixedBuilderTriplesUtf8 tripBuilder = - BFB.contramapBuilder (word12AtUtf8 36 . pairMacUtf8) tripBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word12AtUtf8 24 . pairMacUtf8) tripBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word12AtUtf8 12 . pairMacUtf8) tripBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word12AtUtf8 0 . pairMacUtf8) tripBuilder + BFB.contramapBuilder (word12AtUtf8 36 . pairMacUtf8) tripBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word12AtUtf8 24 . pairMacUtf8) tripBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word12AtUtf8 12 . pairMacUtf8) tripBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word12AtUtf8 0 . pairMacUtf8) tripBuilder {-# INLINE fixedBuilderTriplesUtf8 #-} fixedBuilderQuadruplesUtf8 :: BFB.Builder Word8 -> BFB.Builder PairUtf8 fixedBuilderQuadruplesUtf8 pairBuilder = - BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder + BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder {-# INLINE fixedBuilderQuadruplesUtf8 #-} fixedBuilderPairsUtf8 :: BFB.Builder Word8 -> BFB.Builder PairUtf8 fixedBuilderPairsUtf8 pairBuilder = - BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder - <> BFB.contramapBuilder pairSepUtf8 BFB.word8 - <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder + BFB.contramapBuilder (word8AtUtf8 40 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 32 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 24 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 16 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 8 . pairMacUtf8) pairBuilder + <> BFB.contramapBuilder pairSepUtf8 BFB.word8 + <> BFB.contramapBuilder (word8AtUtf8 0 . pairMacUtf8) pairBuilder {-# INLINE fixedBuilderPairsUtf8 #-} fixedBuilderNoSeparatorUtf8 :: BFB.Builder Word8 -> BFB.Builder Mac fixedBuilderNoSeparatorUtf8 hexBuilder = - BFB.contramapBuilder (word8AtUtf8 40) hexBuilder - <> BFB.contramapBuilder (word8AtUtf8 32) hexBuilder - <> BFB.contramapBuilder (word8AtUtf8 24) hexBuilder - <> BFB.contramapBuilder (word8AtUtf8 16) hexBuilder - <> BFB.contramapBuilder (word8AtUtf8 8) hexBuilder - <> BFB.contramapBuilder (word8AtUtf8 0) hexBuilder + BFB.contramapBuilder (word8AtUtf8 40) hexBuilder + <> BFB.contramapBuilder (word8AtUtf8 32) hexBuilder + <> BFB.contramapBuilder (word8AtUtf8 24) hexBuilder + <> BFB.contramapBuilder (word8AtUtf8 16) hexBuilder + <> BFB.contramapBuilder (word8AtUtf8 8) hexBuilder + <> BFB.contramapBuilder (word8AtUtf8 0) hexBuilder {-# INLINE fixedBuilderNoSeparatorUtf8 #-} word8AtUtf8 :: Int -> Mac -> Word8 @@ -729,76 +788,88 @@ 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. +{- | 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 + 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 + 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 + 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 + 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 + where + !i = 3# *# i0 setByteArray# arr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) + where + go ix# s0 = + if isTrue# (ix# <# len#) then case writeByteArray# arr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 setOffAddr# addr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) + where + go ix# s0 = + if isTrue# (ix# <# len#) then case writeOffAddr# addr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 macToWord16A# :: Mac -> Word# -{-# inline macToWord16A# #-} +{-# INLINE macToWord16A# #-} macToWord16A# (Mac w) = case word64ToWord16 (unsafeShiftR w 32) of Compat.W16# x -> x macToWord16B# :: Mac -> Word# -{-# inline macToWord16B# #-} +{-# INLINE macToWord16B# #-} macToWord16B# (Mac w) = case word64ToWord16 (unsafeShiftR w 16) of Compat.W16# x -> x macToWord16C# :: Mac -> Word# -{-# inline macToWord16C# #-} +{-# 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)) +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 @@ -812,9 +883,10 @@ -- It also uses the smart constructor instead -- of the actual constructor instance Show Mac where - showsPrec p (Mac addr) = showParen (p > 10) - $ showString "mac " - . showHexWord48 addr + showsPrec p (Mac addr) = + showParen (p > 10) $ + showString "mac " + . showHexWord48 addr instance Read Mac where readPrec = parens $ prec 10 $ do @@ -842,43 +914,52 @@ showHexWord48 :: Word64 -> ShowS showHexWord48 w = showString "0x" . go 11 - where + where go :: Int -> ShowS - go !ix = if ix >= 0 - then showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) (ix * 4)) .&. 0xF)) . go (ix - 1) - else id + go !ix = + if ix >= 0 + then showChar (nibbleToHex ((unsafeShiftR (fromIntegral w) (ix * 4)) .&. 0xF)) . go (ix - 1) + else id nibbleToHex :: Word -> Char nibbleToHex w | w < 10 = chr (fromIntegral (w + 48)) | otherwise = chr (fromIntegral (w + 87)) --- | A 'MacCodec' allows users to control the encoding/decoding --- of their 'Mac' addresses. +{- | A 'MacCodec' allows users to control the encoding/decoding + of their 'Mac' addresses. +-} data MacCodec = MacCodec { macCodecGrouping :: !MacGrouping , macCodecUpperCase :: !Bool - } deriving (Eq,Ord,Show,Read,Generic,Data) + } + deriving (Eq, Ord, Show, Read, Generic, Data) --- | The format expected by the mac address parser. The 'Word8' taken --- by some of these constructors is the ascii value of the character --- to be used as the separator. This is typically a colon, a hyphen, or --- a space character. All decoding functions are case insensitive. +{- | The format expected by the mac address parser. The 'Word8' taken + by some of these constructors is the ascii value of the character + to be used as the separator. This is typically a colon, a hyphen, or + a space character. All decoding functions are case insensitive. +-} data MacGrouping - = MacGroupingPairs !Char -- ^ Two-character groups, @FA:2B:40:09:8C:11@ - | MacGroupingTriples !Char -- ^ Three-character groups, @24B-F0A-025-829@ - | MacGroupingQuadruples !Char -- ^ Four-character groups, @A220.0745.CAC7@ - | MacGroupingNoSeparator -- ^ No separator, @24AF4B5B0780@ - deriving (Eq,Ord,Show,Read,Generic,Data) + = -- | 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 + 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 @@ -898,7 +979,7 @@ case v of Aeson.String t -> case AT.parseOnly p t of - Left err -> fail err + Left err -> fail err Right res -> return res _ -> fail "expected a String" @@ -906,11 +987,10 @@ -- than 256. unsafeWord48FromOctets :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 unsafeWord48FromOctets a b c d e f = - fromIntegral - $ unsafeShiftL a 40 - .|. unsafeShiftL b 32 - .|. unsafeShiftL c 24 - .|. unsafeShiftL d 16 - .|. unsafeShiftL e 8 - .|. f - + fromIntegral $ + unsafeShiftL a 40 + .|. unsafeShiftL b 32 + .|. unsafeShiftL c 24 + .|. unsafeShiftL d 16 + .|. unsafeShiftL e 8 + .|. f diff --git a/src/Net/Types.hs b/src/Net/Types.hs --- a/src/Net/Types.hs +++ b/src/Net/Types.hs @@ -1,18 +1,16 @@ -{-| This module re-exports all of the thematic types that this library defines. --} +-- | This module re-exports all of the thematic types that this library defines. module Net.Types - ( IPv4(..) - , IPv6(..) - , IP(..) - , IPv4Range(..) - , IPv6Range(..) - , Mac(..) - , MacCodec(..) - , MacGrouping(..) + ( IPv4 (..) + , IPv6 (..) + , IP (..) + , IPv4Range (..) + , IPv6Range (..) + , Mac (..) + , MacCodec (..) + , MacGrouping (..) ) where -import Net.IPv6 (IPv6(..),IPv6Range(..)) -import Net.IPv4 (IPv4(..), IPv4Range(..)) -import Net.IP (IP(..)) -import Net.Mac (Mac(..),MacCodec(..),MacGrouping(..)) - +import Net.IP (IP (..)) +import Net.IPv4 (IPv4 (..), IPv4Range (..)) +import Net.IPv6 (IPv6 (..), IPv6Range (..)) +import Net.Mac (Mac (..), MacCodec (..), MacGrouping (..)) diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -1,40 +1,39 @@ module Main (main) where import Criterion.Main -import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..)) -import Data.Maybe (fromJust) -import Data.Primitive (PrimArray,foldlPrimArray') import Data.Bool (bool) -import System.Random (mkStdGen,randoms) -import qualified Data.Bytes as Bytes +import Data.Maybe (fromJust) +import Data.Primitive (PrimArray, foldlPrimArray') import qualified Data.Text as Text -import qualified Net.Mac as Mac import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 +import qualified Net.Mac as Mac +import Net.Types (IPv4 (..), MacCodec (..), MacGrouping (..)) +import System.Random (mkStdGen, randoms) -import qualified Naive -import qualified IPv4Text1 -import qualified IPv4Text2 +import qualified Data.Bytes.Text.Ascii as Ascii +import qualified GHC.Exts as Exts import qualified IPv4ByteString1 import qualified IPv4DecodeText1 import qualified IPv4DecodeText2 -import qualified GHC.Exts as Exts --- import qualified IPv4TextVariableBuilder +import qualified IPv4Text1 +import qualified IPv4Text2 +import qualified Naive main :: IO () main = do let ipAddr = IPv4 1000000009 ipText = Text.pack "192.168.5.99" - ipBytes = Bytes.fromAsciiString "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 = Bytes.fromAsciiString "1:2:3:4:5:6:7:8" + 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 = Bytes.fromAsciiString ip6ComplicatedStr + ip6ComplicatedBytes = Ascii.fromString ip6ComplicatedStr ip6Complicated = fromJust $ IPv6.decode (Text.pack ip6ComplicatedStr) ip6TextSkip = Text.pack "1:2::7:8" ip6Skip = fromJust $ IPv6.decode ip6TextSkip @@ -42,74 +41,86 @@ ip6Hex = fromJust $ IPv6.decode ip6TextHex hundredAddrs = Exts.fromList (map IPv4 (take 100 (randoms (mkStdGen 42)))) :: PrimArray IPv4 defaultMain - [ bgroup "Mac to Text" - [ bench "Current Implementation, pairs" $ whnf Mac.encode mac - , bench "Current Implementation, no separator" - $ whnf (Mac.encodeWith (MacCodec MacGroupingNoSeparator True)) mac - , bench "Current Implementation, quads" - $ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac - , bench "Current Implementation, triples" - $ whnf (Mac.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac - ] - , bgroup "Mac to ByteString" - [ bench "Current Implementation, pairs" $ whnf Mac.encodeUtf8 mac - , bench "Current Implementation, no separator" - $ whnf (Mac.encodeWithUtf8 (MacCodec MacGroupingNoSeparator True)) mac - ] - , bgroup "IPv4 to 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 - ] + [ 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 #-} +{-# NOINLINE manyReserved #-} manyReserved x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.reserved addr) + acc) 0 x manyPrivate :: PrimArray IPv4 -> Int -{-# noinline manyPrivate #-} +{-# NOINLINE manyPrivate #-} manyPrivate x = foldlPrimArray' (\acc addr -> bool 0 1 (IPv4.private addr) + acc) 0 x diff --git a/test/IPv4ByteString1.hs b/test/IPv4ByteString1.hs --- a/test/IPv4ByteString1.hs +++ b/test/IPv4ByteString1.hs @@ -1,43 +1,48 @@ module IPv4ByteString1 where -import Net.Types (IPv4(..)) +import Net.Types (IPv4 (..)) -import Data.ByteString.Internal as I import Data.Bits +import Data.ByteString.Internal as I +import Data.Word import Foreign.Ptr import Foreign.Storable -import Data.Word encode :: IPv4 -> ByteString -encode (IPv4 w) = I.unsafeCreateUptoN 15 (\ptr1 -> - do (len1,ptr2) <- writeWord ptr1 w1 - poke ptr2 dot - (len2,ptr3) <- writeWord (ptr2 `plusPtr` 1) w2 - poke ptr3 dot - (len3,ptr4) <- writeWord (ptr3 `plusPtr` 1) w3 - poke ptr4 dot - (len4,_) <- writeWord (ptr4 `plusPtr` 1) w4 - return (3 + len1 + len2 + len3 + len4)) - where w1 = fromIntegral $ shiftR w 24 - w2 = fromIntegral $ shiftR w 16 - w3 = fromIntegral $ shiftR w 8 - w4 = fromIntegral w - dot = 46 - writeWord :: Ptr Word8 -> Word8 -> IO (Int,Ptr Word8) - writeWord ptr word - | word >= 100 = do - let (word1,char3) = word `quotRem` 10 - (char1,char2) = word1 `quotRem` 10 - poke ptr (char1 + 48) - poke (ptr `plusPtr` 1) (char2 + 48) - poke (ptr `plusPtr` 2) (char3 + 48) - return (3,ptr `plusPtr` 3) - | word >= 10 = do - let (char1,char2) = word `quotRem` 10 - poke ptr (char1 + 48) - poke (ptr `plusPtr` 1) (char2 + 48) - return (2,ptr `plusPtr` 2) - | otherwise = do - poke ptr (word + 48) - return (1,ptr `plusPtr` 1) - +encode (IPv4 w) = + I.unsafeCreateUptoN + 15 + ( \ptr1 -> + do + (len1, ptr2) <- writeWord ptr1 w1 + poke ptr2 dot + (len2, ptr3) <- writeWord (ptr2 `plusPtr` 1) w2 + poke ptr3 dot + (len3, ptr4) <- writeWord (ptr3 `plusPtr` 1) w3 + poke ptr4 dot + (len4, _) <- writeWord (ptr4 `plusPtr` 1) w4 + return (3 + len1 + len2 + len3 + len4) + ) + where + w1 = fromIntegral $ shiftR w 24 + w2 = fromIntegral $ shiftR w 16 + w3 = fromIntegral $ shiftR w 8 + w4 = fromIntegral w + dot = 46 + writeWord :: Ptr Word8 -> Word8 -> IO (Int, Ptr Word8) + writeWord ptr word + | word >= 100 = do + let (word1, char3) = word `quotRem` 10 + (char1, char2) = word1 `quotRem` 10 + poke ptr (char1 + 48) + poke (ptr `plusPtr` 1) (char2 + 48) + poke (ptr `plusPtr` 2) (char3 + 48) + return (3, ptr `plusPtr` 3) + | word >= 10 = do + let (char1, char2) = word `quotRem` 10 + poke ptr (char1 + 48) + poke (ptr `plusPtr` 1) (char2 + 48) + return (2, ptr `plusPtr` 2) + | otherwise = do + poke ptr (word + 48) + return (1, ptr `plusPtr` 1) diff --git a/test/IPv4DecodeText1.hs b/test/IPv4DecodeText1.hs --- a/test/IPv4DecodeText1.hs +++ b/test/IPv4DecodeText1.hs @@ -1,30 +1,31 @@ module IPv4DecodeText1 where -import Net.Types -import Data.Word -import Data.Text.Internal (Text(..)) import Control.Monad -import Data.Bits ((.|.),shiftL) -import qualified Data.Text as Text -import qualified Data.Text.Read as TextRead +import Data.Bits (shiftL, (.|.)) +import qualified Data.Text as Text +import Data.Text.Internal (Text (..)) +import qualified Data.Text.Read as TextRead +import Data.Word +import Net.Types stripDecimal :: Text -> Either String Text stripDecimal t = case Text.uncons t of Nothing -> Left "expected a dot but input ended instead" - Just (c,tnext) -> if c == '.' - then Right tnext - else Left "expected a dot but found a different character" + Just (c, tnext) -> + if c == '.' + then Right tnext + else Left "expected a dot but found a different character" {-# INLINE stripDecimal #-} decodeIPv4TextEither :: Text -> Either String Word32 decodeIPv4TextEither t1' = do - (a,t2) <- TextRead.decimal t1' + (a, t2) <- TextRead.decimal t1' t2' <- stripDecimal t2 - (b,t3) <- TextRead.decimal t2' + (b, t3) <- TextRead.decimal t2' t3' <- stripDecimal t3 - (c,t4) <- TextRead.decimal t3' + (c, t4) <- TextRead.decimal t3' t4' <- stripDecimal t4 - (d,t5) <- TextRead.decimal t4' + (d, t5) <- TextRead.decimal t4' when (not (Text.null t5)) (Left "expected end of text but it continued instead") if a > 255 || b > 255 || c > 255 || d > 255 then Left ipOctetSizeErrorMsg @@ -40,8 +41,8 @@ fromOctets' :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 fromOctets' a b c d = - ( shiftL a 24 - .|. shiftL b 16 - .|. shiftL c 8 - .|. d - ) + ( shiftL a 24 + .|. shiftL b 16 + .|. shiftL c 8 + .|. d + ) diff --git a/test/IPv4DecodeText2.hs b/test/IPv4DecodeText2.hs --- a/test/IPv4DecodeText2.hs +++ b/test/IPv4DecodeText2.hs @@ -1,21 +1,22 @@ module IPv4DecodeText2 where -import Net.Types +import qualified Data.Attoparsec.Text as AT +import Data.Bits (shiftL, (.|.)) +import Data.Text.Internal (Text (..)) import Data.Word -import Data.Bits (shiftL,(.|.)) -import Data.Text.Internal (Text(..)) -import qualified Data.Attoparsec.Text as AT +import Net.Types dotDecimalParser :: AT.Parser Word32 -dotDecimalParser = fromOctets' - <$> (AT.decimal >>= limitSize) - <* AT.char '.' - <*> (AT.decimal >>= limitSize) - <* AT.char '.' - <*> (AT.decimal >>= limitSize) - <* AT.char '.' - <*> (AT.decimal >>= limitSize) - where +dotDecimalParser = + fromOctets' + <$> (AT.decimal >>= limitSize) + <* AT.char '.' + <*> (AT.decimal >>= limitSize) + <* AT.char '.' + <*> (AT.decimal >>= limitSize) + <* AT.char '.' + <*> (AT.decimal >>= limitSize) + where limitSize i = if i > 255 then fail ipOctetSizeErrorMsg @@ -31,8 +32,8 @@ fromOctets' :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 fromOctets' a b c d = - ( shiftL a 24 - .|. shiftL b 16 - .|. shiftL c 8 - .|. d - ) + ( shiftL a 24 + .|. shiftL b 16 + .|. shiftL c 8 + .|. d + ) diff --git a/test/IPv4Text1.hs b/test/IPv4Text1.hs --- a/test/IPv4Text1.hs +++ b/test/IPv4Text1.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} + module IPv4Text1 where -import Net.Types (IPv4(..)) -import Data.Text (Text) -import Data.Text.Internal (Text(..)) -import Data.Word -import Data.ByteString (ByteString) import Control.Monad.ST -import Data.Bits (shiftR,(.&.)) -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.ByteString as ByteString +import Data.Bits (shiftR, (.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Unsafe as ByteString -import qualified Data.Text.Array as TArray +import Data.Text (Text) +import qualified Data.Text.Array as TArray +import Data.Text.Internal (Text (..)) +import Data.Word +import Net.Types (IPv4 (..)) ------------------------ -- This implementation operates directly on @@ -27,7 +28,7 @@ w2 = fromIntegral $ 255 .&. shiftR w 16 w3 = fromIntegral $ 255 .&. shiftR w 8 w4 = fromIntegral $ 255 .&. w - (arr,len) = runST $ do + (arr, len) = runST $ do marr <- TArray.new 15 i1 <- putAndCount 0 w1 marr let n1 = i1 @@ -43,15 +44,15 @@ TArray.unsafeWrite marr n3 dot i4 <- putAndCount n3' w4 marr theArr <- TArray.unsafeFreeze marr - return (theArr,i4 + n3') - in Text arr 0 len + return (theArr, i4 + n3') + in Text arr 0 len putAndCount :: Int -> Word8 -> TArray.MArray s -> ST s Int putAndCount pos w marr | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1 | w < 100 = write2 pos w >> return 2 | otherwise = write3 pos w >> return 3 - where + where write2 off i0 = do let i = fromIntegral i0; j = i + i TArray.unsafeWrite marr off $ get2 j @@ -72,7 +73,7 @@ type Codepoint = Word16 #endif -zero,dot :: Codepoint +zero, dot :: Codepoint zero = 48 {-# INLINE zero #-} dot = 46 @@ -83,6 +84,7 @@ {-# INLINE i2w #-} -- Note: these double backslashes are need here because CPP is enabled. +{- FOURMOLU_DISABLE -} twoDigits :: ByteString twoDigits = BC8.pack "0001020304050607080910111213141516171819\\ @@ -106,4 +108,4 @@ \217218219220221222223224225226227228229\\ \230231232233234235236237238239240241242\\ \243244245246247248249250251252253254255" - +{- FOURMOLU_ENABLE -} diff --git a/test/IPv4Text2.hs b/test/IPv4Text2.hs --- a/test/IPv4Text2.hs +++ b/test/IPv4Text2.hs @@ -1,11 +1,11 @@ module IPv4Text2 where -import Net.Types (IPv4(..)) +import Data.Bits (shiftR, (.&.)) import Data.Text (Text) -import Data.Bits ((.&.),shiftR) -import Data.Text.Lazy.Builder.Int (decimal) -import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as TBuilder +import Data.Text.Lazy.Builder.Int (decimal) +import Net.Types (IPv4 (..)) ----------------------------------------- -- Text Builder implementation. This ends @@ -17,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 #-} - diff --git a/test/Naive.hs b/test/Naive.hs --- a/test/Naive.hs +++ b/test/Naive.hs @@ -1,31 +1,33 @@ module Naive where -import Net.Types (IPv4(..)) +import Data.ByteString (ByteString) import Data.Text (Text) -import qualified Net.IPv4 as IPv4 import qualified Data.Text as Text -import Text.Read (readMaybe) -import Data.ByteString (ByteString) import Data.Text.Encoding (encodeUtf8) +import qualified Net.IPv4 as IPv4 +import Net.Types (IPv4 (..)) +import Text.Read (readMaybe) encodeByteString :: IPv4 -> ByteString encodeByteString = encodeUtf8 . encodeText encodeText :: IPv4 -> Text -encodeText i = Text.pack $ concat - [ show a - , "." - , show b - , "." - , show c - , "." - , show d - ] - where (a,b,c,d) = IPv4.toOctets i +encodeText i = + Text.pack $ + concat + [ show a + , "." + , show b + , "." + , show c + , "." + , show d + ] + where + (a, b, c, d) = IPv4.toOctets i decodeText :: Text -> Maybe IPv4 decodeText t = case mapM (readMaybe . Text.unpack) (Text.splitOn (Text.pack ".") t) of - Just [a,b,c,d] -> Just (IPv4.fromOctets a b c d) + Just [a, b, c, d] -> Just (IPv4.fromOctets a b c d) _ -> Nothing - diff --git a/test/Net/IPv4Spec.hs b/test/Net/IPv4Spec.hs --- a/test/Net/IPv4Spec.hs +++ b/test/Net/IPv4Spec.hs @@ -1,68 +1,99 @@ {-# OPTIONS_GHC -Wno-deprecations #-} + module Net.IPv4Spec (spec) where -import Prelude hiding (any) + import Data.Bits import Net.IPv4 import Test.Hspec +import Prelude hiding (any) spec :: Spec spec = do - describe "Bits" $ do - it ".&." $ do - any .&. any `shouldBe` any - any .&. loopback `shouldBe` any - loopback .&. broadcast `shouldBe` loopback - broadcast .&. broadcast `shouldBe` broadcast - it ".|." $ do - any .|. any `shouldBe` any - any .|. loopback `shouldBe` loopback - loopback .|. broadcast `shouldBe` broadcast - broadcast .|. broadcast `shouldBe` broadcast - it "xor" $ do - any `xor` any `shouldBe` any - any `xor` loopback `shouldBe` loopback - loopback `xor` broadcast `shouldBe` complement loopback - broadcast `xor` broadcast `shouldBe` any - it "complement" $ do - complement any `shouldBe` broadcast - complement loopback `shouldBe` ipv4 128 255 255 254 - complement broadcast `shouldBe` any - it "shift" $ do - shift any 0 `shouldBe` any - shift broadcast 0 `shouldBe` broadcast - shift broadcast 8 `shouldBe` ipv4 255 255 255 0 - shift broadcast (-8) `shouldBe` ipv4 0 255 255 255 - shift broadcast 32 `shouldBe` any - shift broadcast 40 `shouldBe` any - it "rotate" $ do - rotate loopback 0 `shouldBe` loopback - rotate loopback 0 `shouldBe` loopback - rotate loopback 8 `shouldBe` ipv4 0 0 1 127 - rotate loopback (-8) `shouldBe` ipv4 1 127 0 0 - rotate loopback 32 `shouldBe` loopback - it "bitSize" $ do - bitSize any `shouldBe` 32 - it "bitSizeMaybe" $ do - bitSizeMaybe any `shouldBe` Just 32 - it "isSigned" $ do - isSigned any `shouldBe` False - isSigned broadcast `shouldBe` False - it "testBit" $ do - testBit loopback <$> [0..31] `shouldBe` - [ 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 + 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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,242 +1,311 @@ -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Main (main) where -import Naive +#if MIN_VERSION_base(4,18,0) +#else import Control.Applicative (liftA2) +#endif + +import Data.Bifunctor import Data.Bytes (Bytes) -import Data.Proxy (Proxy(..)) -import Test.Tasty (defaultMain, testGroup, TestTree) -import Test.Tasty.QuickCheck (testProperty) -import Test.QuickCheck (Arbitrary(..),oneof,Gen,elements,choose,(===)) -import Test.HUnit (Assertion,(@?=),(@=?)) +import Data.Proxy (Proxy (..)) +import Naive import Numeric (showHex) -import Test.QuickCheck.Property (failed,succeeded,Result(..)) -import Data.Bifunctor -import Test.QuickCheck.Classes (Laws(..),jsonLaws,showReadLaws,primLaws,boundedEnumLaws,bitsLaws) +import Test.HUnit (Assertion, (@=?), (@?=)) +import Test.QuickCheck (Arbitrary (..), Gen, choose, elements, oneof, (===)) +import Test.QuickCheck.Classes (Laws (..), bitsLaws, boundedEnumLaws, jsonLaws, primLaws, showReadLaws) +import Test.QuickCheck.Property (Result (..), failed, succeeded) +import Test.Tasty (TestTree, defaultMain, testGroup) import qualified Test.Tasty.HUnit as PH +import Test.Tasty.QuickCheck (testProperty) -import Net.Types (IP,IPv4(..),IPv4Range(..),Mac(..),IPv6(..),MacGrouping(..),MacCodec(..),IPv6Range(..)) -import Data.WideWord (Word128(..)) +import qualified Data.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 qualified Data.ByteString.Char8 as BC8 +import Data.WideWord (Word128 (..)) +import qualified Net.IP as IP import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 import qualified Net.Mac as Mac -import qualified Net.IP as IP +import Net.Types (IP, IPv4 (..), IPv4Range (..), IPv6 (..), IPv6Range (..), Mac (..), MacCodec (..), MacGrouping (..)) -import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.ByteString as AB +import qualified Data.Attoparsec.Text as AT +import qualified IPv4ByteString1 import qualified IPv4Text1 import qualified IPv4Text2 -import qualified IPv4ByteString1 + -- import qualified IPv4TextVariableBuilder main :: IO () main = defaultMain tests tests :: TestTree -tests = 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)) - ] +tests = + testGroup + "tests" + [ testGroup + "Encoding and Decoding" + [ testGroup "Currently used IPv4 encode/decode" $ + [ testProperty "Isomorphism" $ + propEncodeDecodeIso IPv4.encode IPv4.decode + , PH.testCase "Decode an IP" testIPv4Decode + ] + ++ testDecodeFailures + , testGroup "Currently used IPv4 encodeShort/decodeShort" $ + [ testProperty "Isomorphism" $ + propEncodeDecodeIso IPv4.encodeShort IPv4.decodeShort + ] + ++ testDecodeFailures + , testGroup + "Currently used IPv4 UTF-8 Bytes decode" + [ testProperty "Isomorphism" $ + propEncodeDecodeIso (byteStringToBytes . IPv4.encodeUtf8) IPv4.decodeUtf8Bytes + , PH.testCase "Encode a MAC Address" testMacEncode + ] + , testGroup + "Currently used MAC Text encode/decode" + [ testProperty "Isomorphism" $ + propEncodeDecodeIsoSettings Mac.encodeWith Mac.decodeWith + , PH.testCase "Encode a MAC Address" testMacEncode + ] + , testGroup + "Currently used MAC ByteString encode/decode" + [ testProperty "Isomorphism" $ + propEncodeDecodeIsoSettings Mac.encodeWithUtf8 Mac.decodeWithUtf8 + , PH.testCase "Lenient Decoding" testLenientMacByteStringParser + ] + , testGroup + "Naive IPv4 encode/decode" + [ testProperty "Isomorphism" $ + propEncodeDecodeIso Naive.encodeText Naive.decodeText + ] + , testGroup + "Text Builder IPv4 Text encode/decode" + [ testProperty "Identical to Naive" $ + propMatching IPv4Text2.encode Naive.encodeText + ] + , -- , testGroup "Variable Text Builder IPv4 Text encode/decode" + -- [ testProperty "Identical to Naive" + -- $ propMatching IPv4TextVariableBuilder.encode Naive.encodeText + -- ] + testGroup + "Raw byte array IPv4 Text encode/decode" + [ testProperty "Identical to Naive" $ + propMatching IPv4Text1.encode Naive.encodeText + ] + , testGroup + "Raw byte array (without lookup table) IPv4 ByteString encode/decode" + [ testProperty "Identical to Naive" $ + propMatching IPv4ByteString1.encode Naive.encodeByteString + ] + , testGroup + "Raw byte array (with lookup table) IPv4 ByteString encode/decode" + [ testProperty "Identical to Naive" $ + propMatching IPv4.encodeUtf8 Naive.encodeByteString + ] + , testGroup + "IPv4 encode/decode" + [ PH.testCase "Parser Test Cases" testIPv4Parser + ] + , testGroup + "IPv6 encode/decode" + [ PH.testCase "Parser Test Cases" $ testIPv6Parser $ \str -> + either + (\_ -> Nothing) + (Just . HexIPv6) + ( AT.parseOnly + (IPv6.parser <* AT.endOfInput) + (Text.pack str) + ) + , PH.testCase "Bytes Parser Test Cases" $ testIPv6Parser $ \str -> + fmap HexIPv6 (IPv6.decodeUtf8Bytes (Ascii.fromString str)) + , PH.testCase "Encode test cases" (testIPv6Encode IPv6.encode) + , PH.testCase "Encode ShortText" (testIPv6Encode (TS.toText . IPv6.encodeShort)) + , PH.testCase + "Parser Failure Test Cases" + (testIPv6ParserFailure expectIPv6ParserFailure) + , PH.testCase + "Bytes Parser Failure Test Cases" + (testIPv6ParserFailure expectIPv6BytesParserFailure) + ] + ] + , testGroup + "IPv4 Range Operations" + [ testProperty "Idempotence of normalizing IPv4 range" $ + propIdempotence IPv4.normalize + , testProperty "Normalize does not affect membership" propNormalizeMember + , testProperty "Membership agrees with bounds" propMemberUpperLower + , testProperty "Range contains self" propRangeSelf + , testGroup + "reserved" + [ PH.testCase "A" $ IPv4.reserved (IPv4.ipv4 0 1 2 3) @=? True + , PH.testCase "B" $ IPv4.reserved (IPv4.ipv4 1 0 0 0) @=? False + , PH.testCase "C" $ IPv4.reserved (IPv4.ipv4 100 64 0 3) @=? True + , PH.testCase "D" $ IPv4.reserved (IPv4.ipv4 127 255 255 255) @=? True + , PH.testCase "E" $ IPv4.reserved (IPv4.ipv4 110 0 0 255) @=? False + , PH.testCase "F" $ IPv4.reserved (IPv4.ipv4 192 0 2 255) @=? True + , PH.testCase "G" $ IPv4.reserved (IPv4.ipv4 203 0 113 0) @=? True + , PH.testCase "H" $ IPv4.reserved (IPv4.ipv4 225 0 0 0) @=? True + , PH.testCase "I" $ IPv4.reserved (IPv4.ipv4 226 0 0 0) @=? True + , PH.testCase "J" $ IPv4.reserved (IPv4.ipv4 255 255 255 254) @=? True + , PH.testCase "K" $ IPv4.reserved (IPv4.ipv4 255 255 255 255) @=? True + , PH.testCase "L" $ IPv4.reserved (IPv4.ipv4 224 0 0 0) @=? True + , PH.testCase "M" $ IPv4.reserved (IPv4.ipv4 239 255 255 255) @=? True + , PH.testCase "N" $ IPv4.reserved (IPv4.ipv4 223 255 255 255) @=? False + , PH.testCase "O" $ IPv4.reserved (IPv4.ipv4 203 0 114 0) @=? False + , PH.testCase "P" $ IPv4.reserved (IPv4.ipv4 203 0 112 255) @=? False + , PH.testCase "Q" $ IPv4.reserved (IPv4.ipv4 203 0 113 255) @=? True + , PH.testCase "R" $ IPv4.reserved (IPv4.ipv4 192 88 100 0) @=? False + , PH.testCase "S" $ IPv4.reserved (IPv4.ipv4 192 88 99 0) @=? True + , PH.testCase "T" $ IPv4.reserved (IPv4.ipv4 192 0 1 0) @=? False + ] + , testGroup + "private" + [ PH.testCase "A" $ IPv4.private (IPv4.ipv4 198 73 8 38) @=? False + , PH.testCase "B" $ IPv4.private (IPv4.ipv4 192 168 100 5) @=? True + , PH.testCase "C" $ IPv4.private (IPv4.ipv4 10 0 0 0) @=? True + , PH.testCase "D" $ IPv4.private (IPv4.ipv4 10 255 255 255) @=? True + ] + ] + , testGroup + "IPv6 Range Operations" + [ testProperty "Idempotence of normalizing IPv6 range" $ + propIdempotence IPv6.normalize + , testProperty "Normalize does not affect membership" $ \i r -> + IPv6.member i r == IPv6.member i (IPv6.normalize r) + , testProperty "Membership agrees with bounds" $ \i r -> + (i >= IPv6.lowerInclusive r && i <= IPv6.upperInclusive r) == IPv6.member i r + , testProperty "Range contains self" $ \r -> + IPv6.member (ipv6RangeBase r) r == True + , testProperty "Idempotence of upperInclusive-lowerInclusive and fromBounds" $ \r -> + IPv6.fromBounds (IPv6.lowerInclusive r) (IPv6.upperInclusive r) === r + , testGroup + "Cases" + [ PH.testCase "A" $ + False + @=? IPv6.contains + (IPv6.range (IPv6.ipv6 0 0 0 1 0 0 0 0) 64) + (IPv6.ipv6 0 0 0 0 0 0 0 0) + , PH.testCase "B" $ + True + @=? IPv6.contains + (IPv6.range (IPv6.ipv6 0 0 0 0 0 0 0 0) 126) + (IPv6.ipv6 0 0 0 0 0 0 0 1) + , PH.testCase "C" $ + False + @=? IPv6.contains + (IPv6.range (IPv6.ipv6 0 0 0 0 0 0 0 0) 125) + (IPv6.ipv6 0 0 0 0 0 0 0 0xFFFF) + ] + ] + , testGroup + "Instances" + [ testGroup + "IPv4" + [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4)) + , lawsToTest (showReadLaws (Proxy :: Proxy IPv4)) + , lawsToTest (bitsLaws (Proxy :: Proxy IPv4)) + ] + , testGroup + "IPv4Range" + [ lawsToTest (jsonLaws (Proxy :: Proxy IPv4Range)) + , lawsToTest (showReadLaws (Proxy :: Proxy IPv4Range)) + ] + , testGroup + "IPv6" + [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6)) + , lawsToTest (showReadLaws (Proxy :: Proxy IPv6)) + , lawsToTest (primLaws (Proxy :: Proxy IPv6)) + , lawsToTest (boundedEnumLaws (Proxy :: Proxy IPv6)) + , lawsToTest (bitsLaws (Proxy :: Proxy IPv6)) + ] + , testGroup + "IPv6Range" + [ lawsToTest (jsonLaws (Proxy :: Proxy IPv6Range)) + , lawsToTest (showReadLaws (Proxy :: Proxy IPv6Range)) + ] + , testGroup + "IP" + [ lawsToTest (jsonLaws (Proxy :: Proxy IP)) + , lawsToTest (showReadLaws (Proxy :: Proxy IP)) + ] + , testGroup + "Mac" + [ lawsToTest (jsonLaws (Proxy :: Proxy Mac)) + , lawsToTest (showReadLaws (Proxy :: Proxy Mac)) + , lawsToTest (primLaws (Proxy :: Proxy Mac)) + ] + ] ] - ] lawsToTest :: Laws -> TestTree lawsToTest (Laws name pairs) = testGroup name (map (uncurry testProperty) pairs) -propEncodeDecodeIso :: (Eq a, Show a, Show b) - => (a -> b) -> (b -> Maybe a) -> 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" - ] + else + failure $ + concat + [ "x: " + , show a + , "\n" + , "f(x): " + , show fa + , "\n" + , "g(f(x)): " + , show gfa + , "\n" + ] -propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e) - => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result +propEncodeDecodeIsoSettings :: + (Eq a, Show a, Show b, Show e) => + (e -> a -> b) -> + (e -> b -> Maybe a) -> + e -> + a -> + Result propEncodeDecodeIsoSettings f g e a = let fa = f e a gfa = g e fa in if gfa == Just a then succeeded - else failure $ concat - [ "env: ", show e, "\n" - , "x: ", show a, "\n" - , "f(x): ", show fa, "\n" - , "g(f(x)): ", show gfa, "\n" - ] + else + failure $ + concat + [ "env: " + , show e + , "\n" + , "x: " + , show a + , "\n" + , "f(x): " + , show fa + , "\n" + , "g(f(x)): " + , show gfa + , "\n" + ] -propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool +propMatching :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool propMatching f g a = f a == g a -propIdempotence :: Eq a => (a -> a) -> a -> Bool +propIdempotence :: (Eq a) => (a -> a) -> a -> Bool propIdempotence f a = f a == f (f a) propNormalizeMember :: IPv4 -> IPv4Range -> Bool @@ -250,58 +319,134 @@ propRangeSelf r = IPv4.member (ipv4RangeBase r) r == True testIPv4Decode :: Assertion -testIPv4Decode = IPv4.decode (Text.pack "124.222.255.0") - @?= Just (IPv4.fromOctets 124 222 255 0) +testIPv4Decode = + IPv4.decode (Text.pack "124.222.255.0") + @?= Just (IPv4.fromOctets 124 222 255 0) testLenientMacByteStringParser :: Assertion testLenientMacByteStringParser = do - go 0xAB 0x12 0x0F 0x1C 0x88 0x79 - "AB:12:0F:1C:88:79" - go 0xAB 0x12 0x0F 0x0C 0xAA 0x76 - "AB1-20F-0CA-A76" - where + go + 0xAB + 0x12 + 0x0F + 0x1C + 0x88 + 0x79 + "AB:12:0F:1C:88:79" + go + 0xAB + 0x12 + 0x0F + 0x0C + 0xAA + 0x76 + "AB1-20F-0CA-A76" + where go a b c d e f str = Just (HexMac (Mac.fromOctets a b c d e f)) - @=? fmap HexMac (Mac.decodeUtf8 (BC8.pack str)) + @=? fmap HexMac (Mac.decodeUtf8 (BC8.pack str)) testIPv4Parser :: Assertion testIPv4Parser = do go 202 10 19 54 "202.10.19.54" go 10 202 96 25 "10.202.96.25" - where + where go a b c d str = Right (IPv4.fromOctets a b c d) - @=? (AB.parseOnly - (IPv4.parserUtf8 <* AT.endOfInput) - (BC8.pack str) - ) + @=? ( AB.parseOnly + (IPv4.parserUtf8 <* AT.endOfInput) + (BC8.pack str) + ) testIPv6Parser :: (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 = Just (HexIPv6 (IPv6.fromWord16s a b c d e f g h)) - @=? - decode str + @=? decode str testIPv6ParserFailure :: (String -> Assertion) -> Assertion testIPv6ParserFailure go = do @@ -350,22 +495,21 @@ expectIPv6ParserFailure :: String -> Assertion expectIPv6ParserFailure str = Left () - @=? - bimap (\_ -> ()) HexIPv6 - (AT.parseOnly - (IPv6.parser <* AT.endOfInput) - (Text.pack str) - ) + @=? bimap + (\_ -> ()) + HexIPv6 + ( AT.parseOnly + (IPv6.parser <* AT.endOfInput) + (Text.pack str) + ) expectIPv6BytesParserFailure :: String -> Assertion expectIPv6BytesParserFailure s = Nothing - @=? - IPv6.decodeUtf8Bytes (Ascii.fromString s) + @=? IPv6.decodeUtf8Bytes (Ascii.fromString s) testIPv6Encode :: (IPv6 -> Text.Text) -> Assertion testIPv6Encode enc = do - -- degenerate cases: "::" `roundTripsTo` "::" "1234::" `roundTripsTo` "1234::" @@ -402,10 +546,9 @@ "::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 + 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) @@ -427,98 +570,117 @@ PH.testCase ("Should fail to decode [" ++ str ++ "]") $ IPv4.decode (Text.pack str) @?= Nothing testMacEncode :: Assertion -testMacEncode = Mac.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F) - @?= Text.pack "ff:00:ab:12:99:0f" +testMacEncode = + Mac.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F) + @?= Text.pack "ff:00:ab:12:99:0f" failure :: String -> Result -failure msg = failed - { reason = msg - , theException = Nothing - } +failure msg = + failed + { reason = msg + , theException = Nothing + } newtype HexMac = HexMac Mac deriving (Eq) instance Show HexMac where showsPrec _ (HexMac v) = - let (a,b,c,d,e,f) = Mac.toOctets v - in showHex a . showChar ':' - . showHex b . showChar ':' - . showHex c . showChar ':' - . showHex d . showChar ':' - . showHex e . showChar ':' - . showHex f - + let (a, b, c, d, e, f) = Mac.toOctets v + in showHex a + . showChar ':' + . showHex b + . showChar ':' + . showHex c + . showChar ':' + . showHex d + . showChar ':' + . showHex e + . showChar ':' + . showHex f newtype HexIPv6 = HexIPv6 IPv6 deriving (Eq) instance Show HexIPv6 where showsPrec _ (HexIPv6 v) = - let (a,b,c,d,e,f,g,h) = IPv6.toWord16s v - in showHex a . showChar ':' - . showHex b . showChar ':' - . showHex c . showChar ':' - . showHex d . showChar ':' - . showHex e . showChar ':' - . showHex f . showChar ':' - . showHex g . showChar ':' - . showHex h - + let (a, b, c, d, e, f, g, h) = IPv6.toWord16s v + in showHex a + . showChar ':' + . showHex b + . showChar ':' + . showHex c + . showChar ':' + . showHex d + . showChar ':' + . showHex e + . showChar ':' + . showHex f + . showChar ':' + . showHex g + . showChar ':' + . showHex h deriving instance Arbitrary IPv4 instance Arbitrary Word128 where arbitrary = Word128 <$> arbitrary <*> arbitrary - shrink (Word128 a b) = filter (/= Word128 a b) - [ Word128 0 0 - , Word128 (div a 2) b - , Word128 a (div b 2) - ] + shrink (Word128 a b) = + filter + (/= Word128 a b) + [ Word128 0 0 + , Word128 (div a 2) b + , Word128 a (div b 2) + ] deriving instance Arbitrary IPv6 -- Half of the test cases generated are IPv6 mapped -- IPv4 addresses. instance Arbitrary IP where - arbitrary = oneof - [ IP.fromIPv4 <$> arbitrary - , IP.fromIPv6 <$> arbitrary - ] + arbitrary = + oneof + [ IP.fromIPv4 <$> arbitrary + , IP.fromIPv6 <$> arbitrary + ] instance Arbitrary Mac where - arbitrary = Mac.fromOctets - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + Mac.fromOctets + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- This instance can generate masks that exceed the recommended -- length of 32. instance Arbitrary IPv4Range where - arbitrary = IPv4.range <$> arbitrary <*> choose (0,32) + arbitrary = IPv4.range <$> arbitrary <*> choose (0, 32) instance Arbitrary IPv6Range where - arbitrary = IPv6.range <$> arbitrary <*> choose (0,128) - shrink (IPv6Range addr mask) = liftA2 IPv6.range - (shrink addr) - (filter (/= mask) [0,div mask 2,if mask > 0 then mask - 1 else 0]) + arbitrary = IPv6.range <$> arbitrary <*> choose (0, 128) + shrink (IPv6Range addr mask) = + liftA2 + IPv6.range + (shrink addr) + (filter (/= mask) [0, div mask 2, if mask > 0 then mask - 1 else 0]) instance Arbitrary MacCodec where arbitrary = MacCodec <$> arbitrary <*> arbitrary instance Arbitrary MacGrouping where - arbitrary = oneof - [ MacGroupingPairs <$> arbitraryMacSeparator - , MacGroupingTriples <$> arbitraryMacSeparator - , MacGroupingQuadruples <$> arbitraryMacSeparator - , pure MacGroupingNoSeparator - ] + arbitrary = + oneof + [ MacGroupingPairs <$> arbitraryMacSeparator + , MacGroupingTriples <$> arbitraryMacSeparator + , MacGroupingQuadruples <$> arbitraryMacSeparator + , pure MacGroupingNoSeparator + ] arbitraryMacSeparator :: Gen Char -arbitraryMacSeparator = elements [':','-','.','_'] +arbitraryMacSeparator = elements [':', '-', '.', '_'] byteStringToBytes :: BC8.ByteString -> Bytes byteStringToBytes = Ascii.fromString . BC8.unpack