diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,17 +1,46 @@ # Revision history for dns-patterns -## 0.1 -- 2022-02-09 +## 0.2.0 -- 2022-08-24 -* Initial release +* Reversed CHANGELOG item order +* Added the following functions: + * 'pprDomainCF' + * 'pprDomainLabelCF' + * 'unsafeMkDomainLabel' + * 'unsafeSingletonDomainLabel' + * 'mkDomainLabel' (smart constructor) + * 'pprPatternCF' + * 'pprLabelPattern' + * 'pprLabelPatternCF' + * 'mkDomain' + * 'getDomainLabel' + * 'getDomainLabelCF' +* Moved following data constructors and fields to an internal module: + * 'DomainLabel' + * 'Domain' + * 'LabelPattern' + * 'DomainPattern' +* Added case-insensitive Eq/Ord for LabelPattern and DomainPattern +* Drastic performance optimizations for pretty printing +* Domain labels and domain label patterns now may only contain '[a-zA-Z0-0_-]', '\.', '\\' and '\OCTAL' +* Split 'Network.DNS.Pattern' into the following modules: + * 'Network.DNS' + * 'Network.DNS.Internal' + * 'Network.DNS.Pattern.Internal' + * 'Network.DNS.Pattern.Internal' -## 0.1.1 -- 2022-07-06 +## 0.1.3 -- 2022-08-19 -* Allow parseAbsDomainRelax for absolute domains +* Fix incorrect Ord instance for 'Domain' and 'DomainLabel' ## 0.1.2 -- 2022-08-18 * Add 'foldCase' and 'foldCaseLabel' -## 0.1.3 -- 2022-08-19 +## 0.1.1 -- 2022-07-06 -* Fix incorrect Ord instance for 'Domain' and 'DomainLabel' +* Allow parseAbsDomainRelax for absolute domains + +## 0.1 -- 2022-02-09 + +* Initial release diff --git a/dns-patterns.cabal b/dns-patterns.cabal --- a/dns-patterns.cabal +++ b/dns-patterns.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: dns-patterns -version: 0.1.3 +version: 0.2.0 author: Victor Nawothnig maintainer: Victor Nawothnig (dminuoso@icloud.com) copyright: (c) 2022 Wobcom GmbH @@ -9,7 +9,8 @@ license-file: LICENSE category: Network description: - See the main module "Network.DNS.Pattern" for full documentation + Domain name pattern matching, parsing and pretty printing utilities. + See the modules "Network.DNS.Pattern" and "Network.DNS" for full documentation. synopsis: DNS name parsing and pattern matching utilities extra-source-files: CHANGELOG.md @@ -19,11 +20,14 @@ build-depends: base ^>= { 4.12.0.0, 4.13.0.0, 4.14.1.0, 4.15.0.0 } , attoparsec ^>= { 0.13.2.5, 0.14.4 } , text ^>= { 1.2.4 } - , bytestring ^>= { 0.10.12 } + , bytestring ^>= { 0.11.3 } library import: all - exposed-modules: Network.DNS.Pattern + exposed-modules: Network.DNS + , Network.DNS.Internal + , Network.DNS.Pattern + , Network.DNS.Pattern.Internal build-depends: parser-combinators ^>= { 1.3.0 } hs-source-dirs: lib ghc-options: -Wall -Wcompat diff --git a/lib/Network/DNS.hs b/lib/Network/DNS.hs new file mode 100644 --- /dev/null +++ b/lib/Network/DNS.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Network.DNS +-- Description : Generic DNS utilities +-- +-- There is no standardized presentation and parsing format for domain names. +-- In this library we assume a domain name and pattern to be specified as a text with an ASCII dot @.@ acting as a separator and terminator. +-- We do not admit arbitrary unicode codepoints, only the following subset of ASCII is acceptable per label: +-- [a-z], [A-Z], [0-9], '_', '-' +-- +-- Punycoding, if desired, must be taken care of the user. +-- +-- In addition, we allow a backslash to be used as an escaping character for the following possible sequences: +-- +-- @ +-- \\. gives a dot inside a label, rather than a label separator +-- \\\\ gives a backslash inside a label +-- \\012 gives an arbitrary octet inside a label as specified by the three octets +-- @ +-- +-- For example: @foo\\.bar.quux.@ is a domain name comprised of two labels @foo.bar@ and @quux@ +module Network.DNS + ( Domain + , getDomain + , mkDomain + , DomainLabel + , getDomainLabel + , getDomainLabelCF + , mkDomainLabel + , unsafeMkDomainLabel + , unsafeSingletonDomainLabel + , foldCase + , foldCaseLabel + + -- * Parsing + , parseAbsDomain + , parseAbsDomainRelax + , parseDomainLabel + , absDomainP + , absDomainRelaxP + , domainLabelP + + -- * Pretty printing + , pprDomain + , pprDomainCF + , pprDomainLabel + , pprDomainLabelCF + ) +where + +import Data.Coerce (coerce) +import GHC.Exts (Addr#, indexWord8OffAddr#) +import GHC.Int (Int(..)) +import GHC.Word (Word8(..)) + +import Control.Applicative.Combinators +import Control.Monad (when) +import Data.Char (ord) +import Data.Foldable (asum) + +import Data.Attoparsec.Text (()) +import qualified Data.Attoparsec.Text as A +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.Short as BS +import qualified Data.Text as T + +import Network.DNS.Internal + +-- | Parse an absolute domain. Convenience wrapper for 'absDomainP'. +parseAbsDomain :: T.Text -> Either String Domain +parseAbsDomain = A.parseOnly (absDomainP <* A.endOfInput) + +-- | Parse a singular domain label. Convenience wrapper for 'domainLabelP'. +parseDomainLabel :: T.Text -> Either String DomainLabel +parseDomainLabel = A.parseOnly (domainLabelP <* A.endOfInput) + +-- | Version of parseAbsDomain that also considers a domain name without a trailing dot +-- to be absolute. +parseAbsDomainRelax :: T.Text -> Either String Domain +parseAbsDomainRelax = A.parseOnly (absDomainRelaxP <* A.endOfInput) + +-- | Turn a 'Domain' into a list of its labels. +-- +-- prop> getDomain . mkDomain ~~~ id +-- prop> mkDomain . getDomain ~~~ id +getDomain :: Domain -> [DomainLabel] +getDomain = coerce + +-- | Turn a list of labels into a 'Domain'. +-- +-- prop> getDomain . mkDomain ~~~ id +-- prop> mkDomain . getDomain ~~~ id +mkDomain :: [DomainLabel] -> Domain +mkDomain = coerce + +-- | Get the wire-representation of a domain label. +{-# INLINE getDomainLabel #-} +getDomainLabel :: DomainLabel -> BS.ShortByteString +getDomainLabel = getDomainLabel_ + +-- | Get the [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3) case-folded wire-representation of a domain label. +{-# INLINE getDomainLabelCF #-} +getDomainLabelCF :: DomainLabel -> BS.ShortByteString +getDomainLabelCF = getDomainLabelCF_ + +-- | Smart constructor for 'DomainLabel' +mkDomainLabel :: BS.ShortByteString -> DomainLabel +mkDomainLabel l = DomainLabel l (BS.map foldCase_ l) + +-- | Unsafely construct a 'DomainLabel'. The argument must already be case-folded according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +unsafeMkDomainLabel :: BS.ShortByteString -> DomainLabel +unsafeMkDomainLabel l = DomainLabel l l + + +-- | Unsafely construct a 'DomainLabel' from a single Word8. The argument must already be case-folded according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +unsafeSingletonDomainLabel :: Word8 -> DomainLabel +unsafeSingletonDomainLabel l = DomainLabel (BS.singleton l) (BS.singleton l) + +-- | Case-folding of a domain according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +-- Note 'Domain' will memoize a case-folded variant for 'Eq', 'Ord' and pretty printing already. This function is not useful to most. +foldCase :: Domain -> Domain +foldCase (Domain ls) = Domain (foldCaseLabel <$> ls) + +-- | Case-folding of a domain label according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +-- Note 'DomainLabel' will memoize a case-folded variant for 'Eq', 'Ord' and pretty printing already. This function is not useful to most. +{-# INLINE foldCaseLabel #-} +foldCaseLabel :: DomainLabel -> DomainLabel +foldCaseLabel (DomainLabel _l cf) = DomainLabel cf cf + +foldCase_ :: Word8 -> Word8 +foldCase_ w = case fromIntegral w of + I# n -> W8# (indexWord8OffAddr# table n) + where + table :: Addr# + table = "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\ + \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\ + \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\ + \\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\ + \\x40\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\ + \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x5b\x5c\x5d\x5e\x5f\ + \\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\ + \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\ + \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\ + \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\ + \\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\ + \\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\ + \\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\ + \\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\ + \\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\ + \\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"# + +-- | Print an arbitrary domain into a presentation format. +-- +-- This function nearly roundtrips with 'parseAbsDomain' up to escape sequence equivalence +-- +-- prop> parseAbsDomain . pprDomain ~~~ id +pprDomain :: Domain -> T.Text +pprDomain (Domain l) = T.pack (fromDList build) + where + build :: DList Char + build = foldr (\x buf -> buildLabel x <> singleton '.' <> buf) mempty l + +-- | Print an arbitrary domain into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +-- +-- This function nearly roundtrips with 'parseAbsDomain' up to escape sequence equivalence and case folding. +-- +-- prop> parseAbsDomain . pprDomainCF ~~~ id +pprDomainCF :: Domain -> T.Text +pprDomainCF (Domain l) = T.pack (fromDList build) + where + build :: DList Char + build = foldr (\x buf -> buildLabelCF x <> singleton '.' <> buf) mempty l + +-- | Print a singular domain label into a presentation format. +pprDomainLabel :: DomainLabel -> T.Text +pprDomainLabel = T.pack . fromDList . buildLabel + +-- | Print a singular domain label into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +pprDomainLabelCF :: DomainLabel -> T.Text +pprDomainLabelCF = T.pack . fromDList . buildLabelCF + + +-- | Attoparsec 'A.Parser' for absolute domains. See 'parseAbsDomainRelax' for a convenience warpper. +-- This variant differs from 'absDomainP' in that it does not care whether the domain +-- name ends in a dot. +absDomainRelaxP :: A.Parser Domain +absDomainRelaxP = do + d <- go + let l = encodedLength d + when (l >= 255) (fail "domain name too long") + pure d + + where + go = Domain <$> domainLabelP `sepBy1` A.char '.' <* optional (A.char '.') + +-- | Calculate the wire-encoded length of a domain name. +encodedLength :: Domain -> Int +encodedLength (Domain labels) = sum (BS.length <$> l') + length l' + where + l' :: [BS.ShortByteString] + l' = getDomainLabel <$> labels + +-- | Attoparsec 'A.Parser' for absolute domains. See 'parseAbsDomain' for a convenience wrapper. +-- For a parser that also admits domain forms without a leading dot, see 'absDomainRelaxP'. +absDomainP :: A.Parser Domain +absDomainP = do + d <- go + let l = encodedLength d + when (l >= 255) (fail "domain name too long") + pure d + + where + go = Domain <$> asum + [ domainLabelP `endBy1` A.char '.' + , [] <$ A.char '.' -- The root domain itself + ] + +octal :: A.Parser Word8 +octal = do + o1 <- v <$> A.satisfy isOctal + o2 <- v <$> A.satisfy isOctal + o3 <- v <$> A.satisfy isOctal + pure (fromIntegral (o1 * 64 + + o2 * 8 + + o3)) + + where + v c = ord c - 48 + + isOctal :: Char -> Bool + isOctal c = c >= '0' && c <= '7' + +-- | Attoparsec 'A.Parser' for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'. +domainLabelP :: A.Parser DomainLabel +domainLabelP = mkDomainLabel . BS.pack <$> (some labelChar) + where + labelChar :: A.Parser Word8 + labelChar = do + c <- A.satisfy (\x -> isLabelChar x || x == '\\') "domain label character" + case c of + '\\' -> escapable + _ -> pure (c2w c) + + escapable :: A.Parser Word8 + escapable = asum + [ c2w <$> A.char '.' + , c2w <$> A.char '\\' + , octal + ] "escapable character" diff --git a/lib/Network/DNS/Internal.hs b/lib/Network/DNS/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Network/DNS/Internal.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Network.DNS.Pattern.Internal +-- Description : Internal DNS types and definitions +-- +-- This module is not part of public API and may change even between patch versions. + +module Network.DNS.Internal + ( DomainLabel(..) + , Domain(..) + , DList(..) + , toDList + , fromDList + , buildLabel + , buildLabelCF + , singleton + , isLabelChar + ) + +where + +import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Short as BS +import Data.Function (on) +import GHC.Word (Word8(..)) + +import Data.Char (isDigit, isLower, isUpper) + +-- | Domain label with case-insensitive 'Eq' and 'Ord' as per [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +data DomainLabel = DomainLabel { getDomainLabel_ :: !BS.ShortByteString + , getDomainLabelCF_ :: !BS.ShortByteString } + +-- | A domain parsed into labels. Each label is a 'BS.ShortByteString' rather than 'T.Text' or 'String' because a label can contain arbitrary bytes. +-- However, the 'Ord' and 'Eq' instances do limited case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +newtype Domain = Domain [DomainLabel] deriving (Eq, Ord) + +instance Ord DomainLabel where + (<=) = (<=) `on` getDomainLabelCF_ + compare = compare `on` getDomainLabelCF_ + +instance Eq DomainLabel where + (==) = (==) `on` getDomainLabelCF_ + +-- | Difference list à la Huhges +newtype DList a = DList ([a] -> [a]) + +-- | Turn a list into 'DList' +{-# INLINE toDList #-} +toDList :: [a] -> DList a +toDList = DList . (++) + +-- | Turn 'DList' back into a list. +{-# INLINE fromDList #-} +fromDList :: DList a -> [a] +fromDList (DList dl) = dl [] + +-- | Create a 'DList' containing just the specified element +{-# INLINE singleton #-} +singleton :: a -> DList a +singleton = DList . (:) + +instance Semigroup (DList a) where + {-# INLINE (<>) #-} + DList l <> DList r = DList (l . r) + +instance Monoid (DList a) where + {-# INLINE mempty #-} + mempty = DList id + +-- | Make a case-folded string from a 'DomainLabel' suitable for pretty printing +{-# INLINE buildLabelCF #-} +buildLabelCF :: DomainLabel -> DList Char +buildLabelCF = buildLabel_ . getDomainLabelCF_ + +-- | Make a string from a 'DomainLabel' suitable for pretty printing +{-# INLINE buildLabel #-} +buildLabel :: DomainLabel -> DList Char +buildLabel = buildLabel_ . getDomainLabel_ + +{-# INLINE buildLabel_ #-} +buildLabel_ :: BS.ShortByteString -> DList Char +buildLabel_ bs = toDList (replace (BS.unpack bs)) + where + {-# INLINE replace #-} + replace :: [Word8] -> [Char] + replace (x:xs) = case x of + _ | isLabelChar (w2c x) + -> (w2c x) : replace xs + + 0x2e -> '\\' : '.' : replace xs + 0x5c -> '\\' : '\\' : replace xs + _ -> '\\' : o1 : o2 : o3 : replace xs + where + (o1, o2, o3) = case quotRem x 8 of + (v1, r3) -> case quotRem v1 8 of + (v2, r2) -> case quotRem v2 8 of + (_, r1) -> (showD r1, showD r2, showD r3) + replace [] = [] + {-# INLINE showD #-} + showD :: Word8 -> Char + showD x = w2c (x + 0x30) + +-- | Predicate selecting characters allowed in a domain label without escaping. +{-# INLINABLE isLabelChar #-} +isLabelChar :: Char -> Bool +isLabelChar x = isLower x || isDigit x || isUpper x || x == '-' || x == '_' diff --git a/lib/Network/DNS/Pattern.hs b/lib/Network/DNS/Pattern.hs --- a/lib/Network/DNS/Pattern.hs +++ b/lib/Network/DNS/Pattern.hs @@ -1,94 +1,15 @@ -- | -- Module : Network.DNS.Pattern --- Description : Generic network related types. --- --- Provides utilities and parsers for a simple domain name pattern language. -{-# LANGUAGE OverloadedStrings #-} -module Network.DNS.Pattern - ( - -- * Domain names - -- $domainNames - parseAbsDomain - , parseAbsDomainRelax - , parseDomainLabel - , absDomainP - , absDomainRelaxP - , Domain(..) - , DomainLabel(..) - , pprDomain - , pprDomainLabel - , foldCase - , foldCaseLabel - - -- * Pattern language - -- $patterns - , parsePattern - , patternWorksInside - , matchesPattern - , domainLabelP - , patternP - , DomainPattern(..) - , LabelPattern(..) - , encodedLength - , pprPattern - ) -where - -import Control.Monad (when) -import Data.Char (isAscii, ord) -import Data.Coerce (coerce) -import Data.Foldable (asum, foldl') -import Data.Function (on) -import Data.Word (Word8) -import Text.Printf (printf) - -import Control.Applicative.Combinators -import Data.Attoparsec.Text (()) -import qualified Data.Attoparsec.Text as A -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TB - -import qualified Data.ByteString as BS --- --- * Domain names --- --- $domainNames --- --- There is no standardized presentation and parsing format for domain names. --- In this library we assume a domain name and pattern to be specified as a text with an ASCII dot @.@ acting as a separator and terminator. --- We do not admit arbitrary unicode codepoints, only ASCII is acceptable. Punycoding, if desired, must be taken care of the user. --- --- Escape sequences --- The domain name and pattern language here allows for the following escape sequences --- --- @ --- \\. gives a dot inside a label, rather than a label separator --- \\\\ gives a backslash inside a label --- \\012 gives an arbitrary octet inside a label as specified by the three octets --- @ --- --- For example: @foo\\.bar.quux.@ is a domain name comprised of two labels @foo.bar@ and @quux@ - - --- * Patterns --- --- $patterns --- --- Patterns can be simple absolute domain names, where labels can be replaced with either a single glob @*@ or a globstar @**@. --- A single glob will match any label in its place, where globstar will greedily match as many labels as possible. --- --- Admits the escape sequences from domain names as well as the following +-- Description : DNS pattern matching -- --- @ --- \\* gives an asterisk inside a label, rather than a glob/globstar. --- @ +-- Patterns can be simple absolute domain names, where labels are replaceable with a single glob @*@ or a globstar @**@. +-- A single glob will match any label in its place, where globstar will greedily match as many labels as possible towards the left. -- +-- Admits the escape sequences from domain names. See 'Network.DNS'. -- -- Note: Currently a globstar is only supported on the left-most label. -- --- Examples or valid patterns are: +-- Examples of valid patterns are: -- -- @ -- *.foo.bar. @@ -97,129 +18,77 @@ -- foo.bar.*. -- @ -type Parser = A.Parser +{-# LANGUAGE OverloadedStrings #-} +module Network.DNS.Pattern + ( -- * Pattern language + DomainPattern + , LabelPattern + , matchesPattern + , patternWorksInside + , labelMatchesPattern --- | A domain pattern. -newtype DomainPattern = DomainPattern - { getDomainPattern :: [LabelPattern] - } deriving (Eq, Ord) + -- * Parsing + , parsePattern + , patternP --- | A domain parsed into labels. Each label is a 'BS.ByteString' rather than 'T.Text' or 'String' because a label can contain arbitrary bytes. --- However, the 'Ord' and 'Eq' instances do limited case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). -newtype Domain = Domain - { getDomain :: [DomainLabel] - } deriving (Eq, Ord) + -- * Pretty printing + , pprPattern + , pprPatternCF + , pprLabelPattern + , pprLabelPatternCF + ) +where --- | Newtype warpper for 'BS.ByteString' that implements case-insensitive 'Eq' and 'Ord' as per [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). -newtype DomainLabel = DomainLabel { getDomainLabel :: BS.ByteString } +import Data.Foldable (asum) -instance Ord DomainLabel where - compare = compare `on` (BS.map foldCase_ . getDomainLabel) +import Control.Applicative.Combinators +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T -instance Eq DomainLabel where - DomainLabel l == DomainLabel r - = BS.map foldCase_ l == BS.map foldCase_ r +import Network.DNS +import Network.DNS.Internal +import Network.DNS.Pattern.Internal --- | Case-folding of a domain according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). -foldCase :: Domain -> Domain -foldCase (Domain ls) = Domain (foldCaseLabel <$> ls) - --- | Case-folding of a domain label according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). -foldCaseLabel :: DomainLabel -> DomainLabel -foldCaseLabel (DomainLabel l) = DomainLabel (BS.map foldCase_ l) - -{-# INLINE foldCase_ #-} -foldCase_ :: Word8 -> Word8 -foldCase_ x = case x of - 0x41 -> c2w 'a' - 0x42 -> c2w 'b' - 0x43 -> c2w 'c' - 0x44 -> c2w 'd' - 0x45 -> c2w 'e' - 0x46 -> c2w 'f' - 0x47 -> c2w 'g' - 0x48 -> c2w 'h' - 0x49 -> c2w 'i' - 0x4a -> c2w 'j' - 0x4b -> c2w 'k' - 0x4c -> c2w 'l' - 0x4d -> c2w 'm' - 0x4e -> c2w 'n' - 0x4f -> c2w 'o' - 0x50 -> c2w 'p' - 0x51 -> c2w 'q' - 0x52 -> c2w 'r' - 0x53 -> c2w 's' - 0x54 -> c2w 't' - 0x55 -> c2w 'u' - 0x56 -> c2w 'v' - 0x57 -> c2w 'w' - 0x58 -> c2w 'x' - 0x59 -> c2w 'y' - 0x5a -> c2w 'z' - _ -> x - --- | Print an arbitrary domain into a presentation format. --- --- This function nearly roundtrips with 'parseAbsDomain' in the sense that octet escape sequences might change case or drop a leading zero. --- --- prop> parseAbsDomain . pretty ~~~ id -pprDomain :: Domain -> T.Text -pprDomain (Domain l) = TL.toStrict (TB.toLazyText build) - where - build :: TB.Builder - build = foldl' (\buf x -> buf <> buildLabel x <> ".") mempty l - --- | Print a singular domain label into a presentation format. -pprDomainLabel :: DomainLabel -> T.Text -pprDomainLabel = TL.toStrict . TB.toLazyText . buildLabel - --- | Print domain into presentation format. +-- | Print domain pattern. -- --- This function nearly roundtrips with 'parsePattern' in the sense that octet escape sequences might change case or drop a leading zero. +-- This function nearly roundtrips with 'parsePattern' up to escape sequence equivalence. -- -- prop> parsePattern . pprPattern ~~~ id pprPattern :: DomainPattern -> T.Text -pprPattern (DomainPattern l) = TL.toStrict (TB.toLazyText build) +pprPattern (DomainPattern l) = T.pack (fromDList build) where - build :: TB.Builder - build = foldl' (\buf x -> buf <> buildLabelPattern x <> ".") mempty l + build = foldr (\x buf -> buildLabelPattern x <> singleton '.' <> buf) mempty l -buildLabel :: DomainLabel -> TB.Builder -buildLabel (DomainLabel d) = BS.foldl' (\buf x -> buf <> go x) mempty d +-- | Print domain pattern after into presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +-- +-- This function nearly roundtrips with 'parsePattern' up to escape sequence equivalence and case folding. +-- +-- prop> parsePattern . pprPatternCF ~~~ id +pprPatternCF :: DomainPattern -> T.Text +pprPatternCF (DomainPattern l) = T.pack (fromDList build) where - go :: Word8 -> TB.Builder - go 0x2e = "\\." - go 0x5c = "\\\\" - go c | c > 0x20 - && c <= 0x7E - = TB.singleton (w2c c) + build = foldr (\x buf -> buildLabelPatternCF x <> singleton '.' <> buf) mempty l - | otherwise - = "\\" <> TB.fromString (printf "%03o" c) +-- | Print a singular domain label pattern into a presentation format. +pprLabelPattern :: LabelPattern -> T.Text +pprLabelPattern = T.pack . fromDList . buildLabelPattern -buildLabelPattern :: LabelPattern -> TB.Builder -buildLabelPattern (DomLiteral d) = BS.foldl' (\buf x -> buf <> go x) mempty d - where - go :: Word8 -> TB.Builder - go 0x2e = "\\." - go 0x5c = "\\\\" - go 0x2a = "\\*" - go c | c > 0x20 - && c <= 0x7E = TB.singleton (w2c c) +-- | Print a singular domain label pattern into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). +pprLabelPatternCF :: LabelPattern -> T.Text +pprLabelPatternCF = T.pack . fromDList . buildLabelPatternCF - | otherwise - = "\\" <> TB.fromString (printf "%03o" c) -buildLabelPattern DomGlob = "*" -buildLabelPattern DomGlobStar = "**" +{-# INLINE buildLabelPattern #-} +buildLabelPattern :: LabelPattern -> DList Char +buildLabelPattern (DomLiteral d) = buildLabel d +buildLabelPattern DomGlob = singleton '*' +buildLabelPattern DomGlobStar = toDList "**" --- | A pattern for a singular label. -data LabelPattern - = DomLiteral BS.ByteString -- ^ Represents an exact label that must be matched. - | DomGlob -- ^ Represents a single asterisk glob matching any arbitrary domain at a given level. - | DomGlobStar -- ^ Represents a double asterisk matching any arbitrary subdomain at a given level. - deriving (Eq, Ord, Show) +{-# INLINE buildLabelPatternCF #-} +buildLabelPatternCF :: LabelPattern -> DList Char +buildLabelPatternCF (DomLiteral d) = buildLabelCF d +buildLabelPatternCF DomGlob = singleton '*' +buildLabelPatternCF DomGlobStar = toDList "**" -- | Given a pattern and a DNS zone specified by a domain name, test whether or not the pattern -- is applicable beneath that zone. @@ -238,7 +107,7 @@ go [] [] = True go [] _ls = False go _p [] = True - go (p:ps) (l:ls) = labelMatchesPattern (getDomainLabel l) p && go ps ls + go (p:ps) (l:ls) = labelMatchesPattern l p && go ps ls -- | Test whether a given domain matches a 'DomainPattern' matchesPattern :: Domain -> DomainPattern -> Bool @@ -249,17 +118,17 @@ go [] _ps = False go _ls [] = False go _ls [DomGlobStar] = True - go (l:ls) (p:ps) = labelMatchesPattern (getDomainLabel l) p && go ls ps + go (l:ls) (p:ps) = labelMatchesPattern l p && go ls ps -- | Test whether a single label matches a label pattern -labelMatchesPattern :: BS.ByteString -> LabelPattern -> Bool +labelMatchesPattern :: DomainLabel -> LabelPattern -> Bool labelMatchesPattern _l DomGlob = True labelMatchesPattern l (DomLiteral p) = l == p labelMatchesPattern _l DomGlobStar = True --- | Parser for domain patterns. See 'parsePattern' for a convenince wrapper. -patternP :: Parser DomainPattern +-- | Attoparsec 'A.Parser' for domain patterns. See 'parsePattern' for a convenince wrapper. +patternP :: A.Parser DomainPattern patternP = asum [ do p <- litGlobStar <* A.char '.' ps <- litGlob `endBy` A.char '.' pure (DomainPattern (p:ps)) @@ -267,123 +136,17 @@ , DomainPattern [] <$ A.char '.' -- Literal pattern of the root domain "." ] where - litGlobStar :: Parser LabelPattern - litGlobStar = asum [ DomLiteral <$> patternLabelP + litGlobStar :: A.Parser LabelPattern + litGlobStar = asum [ DomLiteral <$> domainLabelP , DomGlobStar <$ A.string "**" , DomGlob <$ A.char '*' ] - litGlob :: Parser LabelPattern - litGlob = asum [ DomLiteral <$> patternLabelP + litGlob :: A.Parser LabelPattern + litGlob = asum [ DomLiteral <$> domainLabelP , DomGlob <$ A.char '*' ] -- | Parse a domain pattern. Convenience wrapper for 'patternP. parsePattern :: T.Text -> Either String DomainPattern parsePattern = A.parseOnly (patternP <* A.endOfInput) - --- | Parse an absolute domain. Convenience wrapper for 'absDomainP'. -parseAbsDomain :: T.Text -> Either String Domain -parseAbsDomain = A.parseOnly (absDomainP <* A.endOfInput) - --- | Parse a singular domain label. Convenience wrapper for 'domainLabelP'. -parseDomainLabel :: T.Text -> Either String DomainLabel -parseDomainLabel = A.parseOnly (domainLabelP <* A.endOfInput) - --- | Version of parseAbsDomain that also considers a domain name without a trailing dot --- to be absolute. -parseAbsDomainRelax :: T.Text -> Either String Domain -parseAbsDomainRelax = A.parseOnly (absDomainRelaxP <* A.endOfInput) - --- | Parser for absolute domains. See 'parseAbsDomainRelax' for a convenience warpper. --- This variant differs from 'absDomainP' in that it does not care whether the domain --- name is terminated with a dot. -absDomainRelaxP :: Parser Domain -absDomainRelaxP = do - d <- go - let l = encodedLength d - when (l >= 255) (fail "domain name too long") - pure d - - where - go = Domain <$> domainLabelP `sepBy1` A.char '.' <* optional (A.char '.') - --- | Calculate the wire-encoded length of a domain name. -encodedLength :: Domain -> Int -encodedLength (Domain labels) = sum (BS.length <$> l') + length l' - where - l' = coerce labels :: [BS.ByteString] - --- | Parser for absolute domains. See 'parseAbsDomain' for a convenience wrapper. --- For a parser that also admits domain forms without a leading dot, see 'absDomainRelaxP'. -absDomainP :: Parser Domain -absDomainP = do - d <- go - let l = encodedLength d - when (l >= 255) (fail "domain name too long") - pure d - - where - go = Domain <$> asum - [ domainLabelP `endBy1` A.char '.' - , [] <$ A.char '.' -- The root domain itself - ] - -patternLabelP :: Parser BS.ByteString -patternLabelP = do - r <- BS.pack <$> (some labelChar) - when (BS.length r >= 64) (fail "label must not be longer than 63 octets") - pure r - where - labelChar :: Parser Word8 - labelChar = do - c <- A.satisfy (\x -> x /= '.' - && x /= '*' - && isAscii x - ) "pattern label character" - case c of - '\\' -> escapable - _ -> pure (c2w c) - - escapable :: Parser Word8 - escapable = asum - [ c2w <$> A.char '.' - , c2w <$> A.char '\\' - , c2w <$> A.char '*' - , octal - ] "escapable character" - -octal :: Parser Word8 -octal = do - o1 <- v <$> A.satisfy isOctal - o2 <- v <$> A.satisfy isOctal - o3 <- v <$> A.satisfy isOctal - pure (fromIntegral (o1 * 64 + - o2 * 8 + - o3)) - - where - v c = ord c - 48 - - isOctal :: Char -> Bool - isOctal c = c >= '0' && c <= '7' - --- | Parser for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'. -domainLabelP :: Parser DomainLabel -domainLabelP = DomainLabel . BS.pack <$> (some labelChar) - where - labelChar :: Parser Word8 - labelChar = do - c <- A.satisfy (\x -> x /= '.' - && isAscii x - ) "domain label character" - case c of - '\\' -> escapable - _ -> pure (c2w c) - - escapable :: Parser Word8 - escapable = asum - [ c2w <$> A.char '.' - , c2w <$> A.char '\\' - , octal - ] "escapable character" diff --git a/lib/Network/DNS/Pattern/Internal.hs b/lib/Network/DNS/Pattern/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Network/DNS/Pattern/Internal.hs @@ -0,0 +1,27 @@ +-- | +-- Module : Network.DNS.Pattern.Internal +-- Description : Internal pattern types and definitions +-- +-- This module is not part of public API and may change even between patch versions. +module Network.DNS.Pattern.Internal + ( DomainLabel(..) + , Domain(..) + , LabelPattern(..) + , DomainPattern(..) + ) + +where + +import Network.DNS.Internal + +-- | A domain pattern. +newtype DomainPattern = DomainPattern + { getDomainPattern :: [LabelPattern] + } deriving (Eq, Ord) + +-- | A pattern for a singular label. +data LabelPattern + = DomLiteral DomainLabel -- ^ Represents an exact label that must be matched. + | DomGlob -- ^ Represents a single asterisk glob matching any arbitrary domain at a given level. + | DomGlobStar -- ^ Represents a double asterisk matching any arbitrary subdomain at a given level. + deriving (Eq, Ord) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} module Main where @@ -11,32 +12,41 @@ import Test.HUnit.Base import Test.HUnit.Text +import GHC.IO.Handle (NewlineMode(inputNL)) +import Network.DNS import Network.DNS.Pattern +import Network.DNS.Pattern.Internal instance IsString DomainPattern where - fromString s = case parsePattern (T.pack s) of - Right s -> s - Left err -> error ("DomPat: no parse, " <> err) + fromString = unsafeParseDomainPattern . T.pack instance IsString DomainLabel where fromString s = case parseDomainLabel (T.pack s) of Right s -> s - Left err -> error ("DomainLabel: no parse, " <> err) + Left err -> error ("DomainLabel: failed to parse: \"" <> s <> "\"") instance IsString Domain where - fromString s = case parseAbsDomain (T.pack s) of - Right s -> s - Left err -> error ("Domain: no parse, " <> err) + fromString = unsafeParseDomain . T.pack instance Show Domain where show = T.unpack . pprDomain -instance Show DomainPattern where - show = T.unpack . pprPattern - +deriving instance Show DomainPattern instance Show DomainLabel where show = T.unpack . pprDomainLabel +deriving instance Show LabelPattern + +unsafeParseDomainPattern :: T.Text -> DomainPattern +unsafeParseDomainPattern s = case parsePattern s of + Right s -> s + Left err -> error ("DomPat: failed to parse: " <> T.unpack s) + +unsafeParseDomain :: T.Text -> Domain +unsafeParseDomain s = case parseAbsDomain s of + Right s -> s + Left err -> error ("Domain: failed to parse: " <> T.unpack s) + main :: IO () main = do runTestTTAndExit $ TestList @@ -46,6 +56,7 @@ , caseFoldSpecs , patternContainedSpecs , pprRoundTrips + , pprSpecs ] @@ -140,10 +151,9 @@ (parsePattern ".") , TestCase $ assertEqual "allow escapable characters in patterns" - (parsePattern "\\..\\*.\\\\.") - (Right (DomainPattern [ DomLiteral "." - , DomLiteral "*" - , DomLiteral "\\" ])) + (parsePattern "\\..\\\\.") + (Right (DomainPattern [ DomLiteral (mkDomainLabel ".") + , DomLiteral (mkDomainLabel "\\") ])) , TestCase $ assertBool "Does not allow unescaped asterisk" (isLeft (parsePattern "a*.")) @@ -164,19 +174,43 @@ isLeft _ = False +pprSpecs :: Test +pprSpecs = TestList + [ let lab = mkDomainLabel "." in + TestCase $ assertEqual "p1: correctly escapes dots" + "\\." + (pprDomainLabel lab) + , let lab = mkDomainLabel "." in + TestCase $ assertEqual "p2: correctly escapes dots after case folding" + "\\." + (pprDomainLabelCF lab) + + , let lab = mkDomainLabel "\\" in + TestCase $ assertEqual "p3: correctly escapes backslash" + "\\\\" + (pprDomainLabel lab) + + , let lab = mkDomainLabel "\\" in + TestCase $ assertEqual "p4: correctly escapes backslash after case folding" + "\\\\" + (pprDomainLabelCF lab) + + , let lab = mkDomainLabel "-_" in + TestCase $ assertEqual "p5: correctly does not escape hyphen or underscore" + "-_" + (pprDomainLabelCF lab) + ] pprRoundTrips :: Test pprRoundTrips = TestList - [ TestCase $ assertEqual "patterns roundtrip between parse and ppr" - (Right True) - (do let input = "**.*.\\.\\*\\000.foo." - r <- parsePattern input - pure (pprPattern r == input)) + [ let input = "**.*.\\.\\000.foo." in + TestCase $ assertEqual "p1: patterns roundtrip between parse and ppr" + input + (pprPattern (unsafeParseDomainPattern input)) - , TestCase $ assertEqual "domains roundtrip between parse and ppr" - (Right True) - (do let input = "**.*\\000.foo." - r <- parseAbsDomain input - pure (pprDomain r == input)) + , let input = "\\000.foo." in + TestCase $ assertEqual "p2: domains roundtrip between parse and ppr" + input + (pprDomain (unsafeParseDomain input)) ]