diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hostaddress + +## 0.1.0.0 -- 2020-02-12 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2020, Lars Kuhtz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +![Cabal Build](https://github.com/larskuhtz/hostaddress/workflows/Cabal%20Build/badge.svg) + +# Haskell Tools for Host Addresses + +This package implements Host addresses as described in RFC2396 section 3.2.2 +with additional consideration of + +* RFC1123 (additional restrictions for hostnames), +* RFC1034 (disambiguate domain names and IPv4 addresses), +* RFC4291 (parsing of IPv6 addresses), and +* RFC3986 and RFC5952 (IPv6 literals within host addresses). + +# Build from Source + +```sh +cabal v2-build +``` + +The following optional build flags are available: + +* `-fwith-aeson`: build `ToJSON` and `FromJSON` instance for use with + [aeson](https://hackage.haskell.org/package/aeson). + +* `-fwith-configuration-tools`: build instances and functions for supporting + the use with + [configuration-tools](https://hackage.haskell.org/package/configuration-tools). + +* `-fwith-quickcheck`: include function for generating arbitrary values and + `Arbitrary` instance for use with + [QuickCheck](https://hackage.haskell.org/package/QuickCheck). + +# Documentation + +Documentation is available at [https://hackage.haskell.org/package/hostaddress/](). diff --git a/hostaddress.cabal b/hostaddress.cabal new file mode 100644 --- /dev/null +++ b/hostaddress.cabal @@ -0,0 +1,79 @@ +cabal-version: 2.2 +name: hostaddress +version: 0.1.0.0 +synopsis: Network Host Addresses +description: + Host addresses as described in RFC2396 section 3.2.2 with additional consideration of + . + * RFC1123 (additional restrictions for hostnames), + * RFC1034 (disambiguate domain names and IPv4 addresses), + * RFC4291 (parsing of IPv6 addresses), and + * RFC3986 and RFC5952 (IPv6 literals within host addresses). + +homepage: https://github.com/larskuhtz/hostaddress +bug-reports: https://github.com/larskuhtz/hostaddress/issues +license: MIT +license-file: LICENSE +author: Lars Kuhtz +maintainer: Lars Kuhtz +copyright: Copyright (c) 2020, Lars Kuhtz +category: Data +tested-with: + GHC==8.6.5 + , GHC==8.8.2 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/larskuhtz/hostaddress.git + +flag with-configuration-tools + description: add support functions and instances for configuration-tools + default: False + manual: True + +flag with-aeson + description: generate ToJSON and FromJSON instances + default: False + manual: True + +flag with-quickcheck + description: include functions for generating arbitrary values and generate Arbitrary instances + default: False + manual: True + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + exposed-modules: + Network.HostAddress + build-depends: + base >=4.10 && <4.15 + , bytestring >=0.10 + , deepseq >=1.4 + , text >=1.2 + , hashable >=1.3 + , case-insensitive >=1.2 + , microlens-th >=0.4 + , exceptions >=0.10 + , attoparsec >=0.13 + , iproute >=1.7 + + if flag(with-aeson) + build-depends: + aeson >=1.4 + + if flag(with-configuration-tools) + build-depends: + configuration-tools >=0.4 + , optparse-applicative >=0.15 + , aeson >=1.4 + + if flag(with-quickcheck) + build-depends: + QuickCheck >=2.13 + diff --git a/src/Network/HostAddress.hs b/src/Network/HostAddress.hs new file mode 100644 --- /dev/null +++ b/src/Network/HostAddress.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +#ifdef VERSION_aeson +{-# LANGUAGE StandaloneDeriving #-} +#endif + +-- | +-- Module: Network.HostAddress +-- Copyright: Copyright © 2020 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Host addresses as described in RFC2396 section 3.2.2 with additional consideration of +-- +-- * RFC1123 (additional restrictions for hostnames), +-- * RFC1034 (disambiguate domain names and IPv4 addresses), +-- * RFC4291 (parsing of IPv6 addresses), and +-- * RFC3986 and RFC5952 (IPv6 literals within host addresses). +-- +-- Port numbers must be within the range @[0,2^16-1]@. +-- +-- All hostnames are considered fully qualified and thus the final dot is +-- omitted. +-- +-- For hostnames we follow the specification for "Server-based Naming Authority" +-- for URIs from RFC2396 section 3.2.2.: +-- +-- @ +-- hostport = host [ ":" port ] +-- host = hostname | IPv4address +-- hostname = *( domainlabel "." ) toplabel [ "." ] +-- domainlabel = alphanum | alphanum *( alphanum | "-" ) alphanum +-- toplabel = alpha | alpha *( alphanum | "-" ) alphanum +-- +-- IPv4address = 1*digit "." 1*digit "." 1*digit "." 1*digit +-- port = *digit +-- @ +-- +-- @1*digit@ designates the decimal representation of an octet. The specification +-- takes the form of hostnames from section 2.1 RFC1123, but limiting the +-- rightmost (top-most) label to the from given in section 3 of RFC1034, which +-- allows to disambiguate domain names and IPv4 addresses. +-- +-- IPv6 Addresses are partially supported. IPv6 address are parsed as described +-- in RFC4291, but embedding of IPv4 addresses is not supported. IPv6 addresses +-- are printed exactly as they where parsed. No normalization is performed. In +-- particular the recommendations from RFC5952 are not considered. For host +-- addresses RFC3986 and RFC5952 are followed by requiring that IPv6 literals +-- are enclosed in square brackets. Anything else from RFC3986, which is +-- concerning URIs is ignored. +-- +-- Additional restriction for hostname apply from RFC1123: labels must have not +-- more than 63 octets, letters are case-insensitive. The maximum length must not +-- exceed 254 octets, excluding the (optional) terminating dot. +-- +-- See for an extensive +-- overview of different standards for host names. +-- +-- Non-ascii characters are encoded via Punycode and are of no concern in this +-- implementation. +-- +module Network.HostAddress +( +-- * Port Numbers + Port +, portToText +, portFromText +, readPortBytes + +-- * Hostnames +, Hostname +, hostnameBytes +, readHostnameBytes +, hostnameToText +, hostnameFromText +, unsafeHostnameFromText + +-- ** Special Host Names +, localhost +, localhostIPv4 +, localhostIPv6 +, anyIpv4 +, broadcast +, loopback +, isReservedHostname +, isPrivateHostname +, isLocalIp + +-- * HostAddresses +, HostAddress(..) +, hostAddressPort +, hostAddressHost +, hostAddressBytes +, readHostAddressBytes +, hostAddressToText +, hostAddressFromText +, unsafeHostAddressFromText + +-- ** Special Host Addresses +, isPrivateHostAddress +, isReservedHostAddress + +#ifdef VERSION_configuration_tools +-- * Configuration Tools Support +, pPort +, pHostname +, pHostAddress +, pHostAddress' +#endif + +#ifdef VERSION_QuickCheck +-- * Arbitrary Values +, arbitraryPort +, arbitraryDomainName +, arbitraryIpV4 +, arbitraryIpV6 +, arbitraryHostname +, arbitraryHostAddress + +-- * Properties +, properties +#endif +) where + +#ifdef VERSION_configuration_tools +import Configuration.Utils hiding ((), (<|>), FromJSON, ToJSON) +#endif + +import Control.Applicative +import Control.DeepSeq (NFData) +import Control.Monad +import Control.Monad.Catch + +#ifdef VERSION_aeson +import Data.Aeson hiding (()) +#endif + +import Data.Attoparsec.ByteString.Char8 +#ifdef VERSION_configuration_tools +import Data.Bifunctor +#endif +import qualified Data.ByteString.Char8 as B8 +import qualified Data.CaseInsensitive as CI +import Data.Hashable (Hashable(..)) +import Data.IP +#ifdef VERSION_QuickCheck +import qualified Data.List as L +#endif +import Data.Maybe +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Word (Word16, Word8) + +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) + +import Lens.Micro.TH (makeLenses) + +#ifdef VERSION_configuration_tools +import qualified Options.Applicative as O +#endif + +#ifdef VERSION_QuickCheck +import Test.QuickCheck +#endif + +-- -------------------------------------------------------------------------- -- +-- Utils + +sshow :: Show a => IsString b => a -> b +sshow = fromString . show +{-# INLINE sshow #-} + +fromJuste :: HasCallStack => Maybe a -> a +fromJuste = fromJust +{-# INLINE fromJuste #-} + +int :: Integral a => Num b => a -> b +int = fromIntegral +{-# INLINE int #-} + +newtype HostAddressParserException = HostAddressParserException T.Text + deriving (Show, Eq, Ord, Generic) + deriving anyclass (Hashable) + deriving newtype (NFData) + +instance Exception HostAddressParserException + +-- -------------------------------------------------------------------------- -- +-- Internal Parsers + +data HostType = HostTypeName | HostTypeIPv4 | HostTypeIPv6 + deriving (Show, Eq, Ord, Generic, Hashable) + +hostParser :: Parser HostType +hostParser + = HostTypeName <$ hostNameParser + <|> HostTypeIPv4 <$ ipV4Parser + <|> HostTypeIPv6 <$ ipV6Parser + "host" + +hostNameParser :: Parser () +hostNameParser = () + <$ many' (domainlabel <* ".") <* toplabel + "hostname" + where + domainlabel = () + <$ alphanum <* optional labelTail + "domainlabel" + + toplabel = () + <$ alpha <* optional labelTail + "toplabel" + + labelTail = alphanumhyphen >>= \case + '-' -> labelTail + _ -> () <$ optional labelTail + + alpha = satisfy isAlpha_ascii + "alpha" + + alphanum = satisfy (\c -> isAlpha_ascii c || isDigit c) + "alphanum" + + alphanumhyphen = satisfy (\c -> isAlpha_ascii c || isDigit c || c == '-') + "alphahumhypen" + +ipV4Parser :: Parser (Word8, Word8, Word8, Word8) +ipV4Parser = (,,,) + <$> (octet <* ".") <*> (octet <* ".") <*> (octet <* ".") <*> octet + "ipv4address" + where + octet :: Parser Word8 + octet = (decimal >>= \(d :: Integer) -> int d <$ guard (d < 256)) + "octet" + +ipV6Parser :: Parser [Maybe Word16] +ipV6Parser = p0 + where + p0 = l1 <$> elision <* endOfInput + <|> l3 <$> elision <*> h16 <*> p2 6 + <|> l2 <$> h16 <*> p1 7 + "IPv6address" + + p1 :: Int -> Parser [Maybe Word16] + p1 0 = l0 <$ endOfInput "IPv6 prefix: too many segments" + p1 i = l1 <$> elision <* endOfInput + <|> l3 <$> elision <*> h16 <*> p2 (i - 2) + <|> l2 <$ ":" <*> h16 <*> p1 (i - 1) + "IPv6 prefix" + + p2 :: Int -> Parser [Maybe Word16] + p2 0 = l0 <$ endOfInput "IPv6 suffix: too many segments" + p2 i = l2 <$ ":" <*> h16 <*> p2 (i - 1) + <|> l0 <$ endOfInput + "IPv6 suffix" + + elision :: Parser (Maybe Word16) + elision = Nothing <$ "::" + + h16 :: Parser (Maybe Word16) + h16 = Just <$> do + h <- hexadecimal @Integer + guard $ h < int (maxBound @Word16) + return $! int h + "h16" + + l0 = [] + l1 = pure + l2 = (:) + l3 a b t = a:b:t + +portParser :: Parser Port +portParser = Port + <$> (decimal >>= \(d :: Integer) -> int d <$ guard (d < 2^(16 :: Int))) + "port" + +parseBytes :: MonadThrow m => T.Text -> Parser a -> B8.ByteString -> m a +parseBytes name parser b = either (throwM . HostAddressParserException . msg) return + $ parseOnly (parser <* endOfInput) b + where + msg e = "Failed to parse " <> sshow b <> " as " <> name <> ": " + <> T.pack e + +-- -------------------------------------------------------------------------- -- +-- Port Numbers + +newtype Port = Port Word16 + deriving (Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + deriving newtype (Show, Real, Integral, Num, Bounded, Enum) + +readPortBytes :: MonadThrow m => B8.ByteString -> m Port +readPortBytes = parseBytes "port" portParser +{-# INLINE readPortBytes #-} + +portToText :: Port -> T.Text +portToText = sshow +{-# INLINE portToText #-} + +portFromText :: MonadThrow m => T.Text -> m Port +portFromText = readPortBytes . T.encodeUtf8 +{-# INLINE portFromText #-} + +-- -------------------------------------------------------------------------- -- +-- Hostnames + +data Hostname + = HostnameName (CI.CI B8.ByteString) + | HostnameIPv4 (CI.CI B8.ByteString) + | HostnameIPv6 (CI.CI B8.ByteString) + deriving (Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +instance Show Hostname where + show = B8.unpack . hostnameBytes + +readHostnameBytes :: MonadThrow m => B8.ByteString -> m Hostname +readHostnameBytes b = parseBytes "hostname" parser b + where + parser = hostParser <* endOfInput >>= \case + HostTypeName -> return $! HostnameName (CI.mk b) + HostTypeIPv4 -> return $! HostnameIPv4 (CI.mk b) + HostTypeIPv6 -> return $! HostnameIPv6 (CI.mk b) +{-# INLINE readHostnameBytes #-} + +localhost :: Hostname +localhost = HostnameName "localhost" +{-# INLINE localhost #-} + +-- | Using explicit IP addresses and not to "localhost" greatly improves +-- networking performance and Mac OS X. +-- +localhostIPv4 :: Hostname +localhostIPv4 = HostnameIPv4 "127.0.0.1" +{-# INLINE localhostIPv4 #-} + +-- | Using explicit IP addresses and not to "localhost" greatly improves +-- networking performance and Mac OS X. +-- +localhostIPv6 :: Hostname +localhostIPv6 = HostnameIPv6 "::1" +{-# INLINE localhostIPv6 #-} + +anyIpv4 :: Hostname +anyIpv4 = HostnameIPv4 "0.0.0.0" +{-# INLINE anyIpv4 #-} + +loopback :: Hostname +loopback = HostnameIPv4 "127.0.0.1" +{-# INLINE loopback #-} + +broadcast :: Hostname +broadcast = HostnameIPv4 "255.255.255.255" +{-# INLINE broadcast #-} + +isPrivateHostname :: Hostname -> Bool +isPrivateHostname (HostnameIPv4 ip) = isPrivateIp (read $ B8.unpack $ CI.original ip) +isPrivateHostname h + | h == localhost = True + | h == localhostIPv4 = True + | h == localhostIPv6 = True + | otherwise = False + +isReservedHostname :: Hostname -> Bool +isReservedHostname (HostnameIPv4 ip) = isReservedIp (read $ B8.unpack $ CI.original ip) +isReservedHostname h = isPrivateHostname h + +isLocalIp :: IPv4 -> Bool +isLocalIp ip = + isMatchedTo ip $ makeAddrRange (toIPv4 [127,0,0,0]) 8 + +isPrivateIp :: IPv4 -> Bool +isPrivateIp ip = or + [ isMatchedTo ip $ makeAddrRange (toIPv4 [10,0,0,0]) 8 + , isMatchedTo ip $ makeAddrRange (toIPv4 [172,16,0,0]) 12 + , isMatchedTo ip $ makeAddrRange (toIPv4 [192,168,0,0]) 16 + ] + +isReservedIp :: IPv4 -> Bool +isReservedIp ip = isLocalIp ip || isPrivateIp ip || or + [ isMatchedTo ip $ makeAddrRange (toIPv4 [0,0,0,0]) 8 + , isMatchedTo ip $ makeAddrRange (toIPv4 [100,64,0,0]) 10 + , isMatchedTo ip $ makeAddrRange (toIPv4 [169,254,0,0]) 16 + , isMatchedTo ip $ makeAddrRange (toIPv4 [192,0,0,0]) 24 + , isMatchedTo ip $ makeAddrRange (toIPv4 [192,0,2,0]) 24 + , isMatchedTo ip $ makeAddrRange (toIPv4 [192,88,99,0]) 24 + , isMatchedTo ip $ makeAddrRange (toIPv4 [192,18,0,0]) 15 + , isMatchedTo ip $ makeAddrRange (toIPv4 [198,51,100,0]) 24 + , isMatchedTo ip $ makeAddrRange (toIPv4 [203,0,113,0]) 24 + , isMatchedTo ip $ makeAddrRange (toIPv4 [224,0,0,0]) 4 + , isMatchedTo ip $ makeAddrRange (toIPv4 [240,0,0,0]) 4 + , isMatchedTo ip $ makeAddrRange (toIPv4 [255,255,255,255]) 32 + ] + +hostnameBytes :: Hostname -> B8.ByteString +hostnameBytes (HostnameName b) = CI.original b +hostnameBytes (HostnameIPv4 b) = CI.original b +hostnameBytes (HostnameIPv6 b) = CI.original b +{-# INLINE hostnameBytes #-} + +hostnameToText :: Hostname -> T.Text +hostnameToText = T.decodeUtf8 . hostnameBytes +{-# INLINE hostnameToText #-} + +hostnameFromText :: MonadThrow m => T.Text -> m Hostname +hostnameFromText = readHostnameBytes . T.encodeUtf8 +{-# INLINE hostnameFromText #-} + +unsafeHostnameFromText :: HasCallStack => T.Text -> Hostname +unsafeHostnameFromText = fromJuste . hostnameFromText +{-# INLINE unsafeHostnameFromText #-} + +-- -------------------------------------------------------------------------- -- +-- Host Addresses + +data HostAddress = HostAddress + { _hostAddressHost :: !Hostname + , _hostAddressPort :: !Port + } + deriving (Show, Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +makeLenses ''HostAddress + +hostAddressBytes :: HostAddress -> B8.ByteString +hostAddressBytes a = host <> ":" <> sshow (_hostAddressPort a) + where + ha = _hostAddressHost a + host = case ha of + HostnameIPv6 _ -> "[" <> hostnameBytes ha <> "]" + _ -> hostnameBytes ha +{-# INLINE hostAddressBytes #-} + +readHostAddressBytes :: MonadThrow m => B8.ByteString -> m HostAddress +readHostAddressBytes bytes = parseBytes "hostaddress" (hostAddressParser bytes) bytes + +-- | Parser a host address. The input bytestring isn't used for parsing but for +-- the constructing the reslt HostAddress. +-- +hostAddressParser :: B8.ByteString -> Parser HostAddress +hostAddressParser b = HostAddress + <$> hostnameParser' + <* ":" + <*> portParser + where + host = B8.init $ fst $ B8.breakEnd (== ':') b + hostnameParser' + = HostnameName (CI.mk host) <$ hostNameParser + <|> HostnameIPv4 (CI.mk host) <$ ipV4Parser + <|> HostnameIPv6 (CI.mk $ B8.init $ B8.tail host) <$ "[" <* ipV6Parser <* "]" + "host" + +hostAddressToText :: HostAddress -> T.Text +hostAddressToText = T.decodeUtf8 . hostAddressBytes +{-# INLINE hostAddressToText #-} + +hostAddressFromText :: MonadThrow m => T.Text -> m HostAddress +hostAddressFromText = readHostAddressBytes . T.encodeUtf8 +{-# INLINE hostAddressFromText #-} + +unsafeHostAddressFromText :: HasCallStack => T.Text -> HostAddress +unsafeHostAddressFromText = fromJuste . hostAddressFromText +{-# INLINE unsafeHostAddressFromText #-} + +isPrivateHostAddress :: HostAddress -> Bool +isPrivateHostAddress (HostAddress n _) = isPrivateHostname n +{-# INLINE isPrivateHostAddress #-} + +isReservedHostAddress :: HostAddress -> Bool +isReservedHostAddress (HostAddress n _) = isReservedHostname n +{-# INLINE isReservedHostAddress #-} + +#ifdef VERSION_aeson +-- -------------------------------------------------------------------------- -- +-- Aeson Instances + +eitherFromText + :: (T.Text -> Either SomeException a) + -> T.Text + -> Either String a +eitherFromText p = either f return . p + where + f e = Left $ case fromException e of + Just (HostAddressParserException err) -> T.unpack err + _ -> displayException e +{-# INLINE eitherFromText #-} + +deriving newtype instance ToJSON Port +deriving newtype instance FromJSON Port + +instance ToJSON HostAddress where + toJSON o = object + [ "hostname" .= _hostAddressHost o + , "port" .= _hostAddressPort o + ] + {-# INLINE toJSON #-} + +instance FromJSON HostAddress where + parseJSON = withObject "HostAddress" $ \o -> HostAddress + <$> o .: "hostname" + <*> o .: "port" + {-# INLINE parseJSON #-} + +instance ToJSON Hostname where + toJSON = toJSON . hostnameToText + {-# INLINE toJSON #-} + +instance FromJSON Hostname where + parseJSON = withText "Hostname" + $! either fail return . eitherFromText hostnameFromText + {-# INLINE parseJSON #-} + +#endif + +#ifdef VERSION_configuration_tools +-- -------------------------------------------------------------------------- -- +-- Configuration Tools Support + +prefixLong :: HasName f => Maybe String -> String -> Mod f a +prefixLong prefix l = long $ maybe "" (<> "-") prefix <> l + +suffixHelp :: Maybe String -> String -> Mod f a +suffixHelp suffix l = help $ l <> maybe "" (" for " <>) suffix + +textReader :: (T.Text -> Either SomeException a) -> ReadM a +textReader p = eitherReader $ first show . p . T.pack +{-# INLINE textReader #-} + +-- | Simple options parser for Port +-- +pPort :: Maybe String -> O.Parser Port +pPort service = O.option (textReader portFromText) + % prefixLong service "port" + <> suffixHelp service "port number" +{-# INLINE pPort #-} + +-- | Simpe option parser for Hostname +-- +pHostname :: Maybe String -> O.Parser Hostname +pHostname service = O.option (textReader hostnameFromText) + % prefixLong service "hostname" + <> suffixHelp service "hostname" +{-# INLINE pHostname #-} + +instance FromJSON (HostAddress -> HostAddress) where + parseJSON = withObject "HostAddress" $ \o -> id + <$< hostAddressHost ..: "hostname" % o + <*< hostAddressPort ..: "port" % o + {-# INLINE parseJSON #-} + +-- | Configuration tools option parser for HostAddress +-- +pHostAddress :: Maybe String -> MParser HostAddress +pHostAddress service = id + <$< hostAddressHost .:: pHostname service + <*< hostAddressPort .:: pPort service + +-- | Simple Option parser for HostAddress +-- +pHostAddress' :: Maybe String -> O.Parser HostAddress +pHostAddress' service = HostAddress <$> pHostname service <*> pPort service + +#endif + +#ifdef VERSION_QuickCheck +-- -------------------------------------------------------------------------- -- +-- Arbitrary Values + +-- TODO should we exclude network, broadcast, otherwise special values? + +-- | Arbitary IPv4 addresses +-- +arbitraryIpV4 :: Gen Hostname +arbitraryIpV4 = HostnameIPv4 . CI.mk . B8.intercalate "." . fmap sshow + <$> replicateM 4 (arbitrary :: Gen Word8) + +-- | Arbitary IPv6 addresses +-- +arbitraryIpV6 :: Gen Hostname +arbitraryIpV6 = HostnameIPv6 . CI.mk . B8.intercalate ":" . fmap sshow + <$> replicateM 8 (arbitrary :: Gen Word8) + +-- | Arbitary domain names +-- +arbitraryDomainName :: Gen Hostname +arbitraryDomainName = sized $ \n -> resize (min n 254) + . fmap (HostnameName . mconcat . L.intersperse ".") + $ (<>) + <$> listOf (arbitraryDomainLabel False) + <*> vectorOf 1 (arbitraryDomainLabel True) + +-- TODO add frequency or used sized to yield a better distribution + +-- | Arbitary domain labels +-- +arbitraryDomainLabel :: Bool -> Gen (CI.CI B8.ByteString) +arbitraryDomainLabel isTop = sized $ \n -> resize (min n 63) + $ CI.mk . B8.pack <$> oneof + [ vectorOf 1 (if isTop then letter else letterOrDigit) + , foldM (\l a -> (l <>) <$> a) [] + [ vectorOf 1 (if isTop then letter else letterOrDigit) + , listOf letterOrDigitOrHyphen + , vectorOf 1 letterOrDigit + ] + ] + where + letter = elements $ ['a'..'z'] <> ['A'..'Z'] + letterOrDigit = elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] + letterOrDigitOrHyphen = elements $ ['a'..'z'] <> ['A'..'Z'] <> ['-'] + +-- | Arbitrary port numbers +-- +arbitraryPort :: Gen Port +arbitraryPort = Port <$> arbitrary + +instance Arbitrary Port where + arbitrary = arbitraryPort + +-- | Arbitrary host names +-- +arbitraryHostname :: Gen Hostname +arbitraryHostname = oneof + [ arbitraryIpV4 + , arbitraryIpV4 + , arbitraryDomainName + -- Note that not every valid domain name is also a valid host name. + -- Generally, a hostname has at least one associated IP address. + -- Also, syntactic restriction apply for certain top-level domains. + , pure (HostnameName "localhost") + , pure localhost + ] + +instance Arbitrary Hostname where + arbitrary = arbitraryHostname + +-- | Arbitrary host adresses +-- +arbitraryHostAddress :: Gen HostAddress +arbitraryHostAddress = HostAddress <$> arbitrary <*> arbitrary + +instance Arbitrary HostAddress where + arbitrary = arbitraryHostAddress + +-- -------------------------------------------------------------------------- -- +-- Properties + +prop_readHostAddressBytes :: HostAddress -> Property +prop_readHostAddressBytes a = readHostAddressBytes (hostAddressBytes a) === Just a + +prop_readHostnameBytes :: Hostname -> Property +prop_readHostnameBytes h = readHostnameBytes (hostnameBytes h) === Just h + +properties :: [(String, Property)] +properties = + [ ("readHostnameBytes", property prop_readHostnameBytes) + , ("readHostAddressBytes", property prop_readHostAddressBytes) + ] +#endif