dns-patterns 0.1.3 → 0.2.0

raw patch · 7 files changed

+550/−339 lines, 7 filesdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−6
• dns-patterns.cabal +8/−4
• lib/Network/DNS.hs +249/−0
• lib/Network/DNS/Internal.hs +105/−0
• lib/Network/DNS/Pattern.hs +67/−304
• lib/Network/DNS/Pattern/Internal.hs +27/−0
• test/Spec.hs +59/−25

@@ -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

@@ -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

@@ -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"

@@ -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 == '_'

@@ -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"

@@ -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)

@@ -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))    ]