dns-patterns 0.2.0 → 0.2.1

raw patch · 6 files changed

+160/−71 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• dns-patterns.cabal +1/−1
• lib/Network/DNS.hs +63/−22
• lib/Network/DNS/Internal.hs +1/−42
• lib/Network/DNS/Pattern.hs +73/−6
• test/Spec.hs +16/−0

@@ -1,5 +1,11 @@ # Revision history for dns-patterns +## 0.2.1 -- 2022-08-24++* Export missing 'LabelPattern' and 'DomainPattern' constructors+* Correctly allow asterisk in domain labels+* Correctly allow escaped asterisk in literal domain label patterns+ ## 0.2.0 -- 2022-08-24  * Reversed CHANGELOG item order

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               dns-patterns-version:            0.2.0+version:            0.2.1 author:             Victor Nawothnig maintainer:         Victor Nawothnig (dminuoso@icloud.com) copyright:          (c) 2022 Wobcom GmbH

@@ -6,12 +6,15 @@ -- 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], '_', '-'+-- [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: --+-- 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@@ -48,6 +51,7 @@   ) where +import           Data.Char (isDigit, isLower, isUpper) import           Data.Coerce (coerce) import           GHC.Exts (Addr#, indexWord8OffAddr#) import           GHC.Int (Int(..))@@ -55,6 +59,7 @@  import           Control.Applicative.Combinators import           Control.Monad (when)+import           Data.ByteString.Internal (w2c) import           Data.Char (ord) import           Data.Foldable (asum) @@ -215,20 +220,10 @@         , [] <$ 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'+-- | Predicate selecting characters allowed in a domain label without escaping.+{-# INLINE isLabelChar #-}+isLabelChar :: Char -> Bool+isLabelChar x = isLower x || isDigit x || isUpper x || x == '-' || x == '_' || x == '*'  -- | Attoparsec 'A.Parser' for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'. domainLabelP :: A.Parser DomainLabel@@ -238,12 +233,58 @@     labelChar = do         c <- A.satisfy (\x -> isLabelChar x || x == '\\') <?> "domain label character"         case c of-            '\\' -> escapable+            '\\' -> escape             _    -> pure (c2w c) -    escapable :: A.Parser Word8-    escapable = asum-        [ c2w <$> A.char '.'-        , c2w <$> A.char '\\'-        , octal-        ] <?> "escapable character"+    escape :: A.Parser Word8+    escape = asum [ c2w <$> A.char '.'+                  , c2w <$> A.char '\\'+                  , octal ]+             <?> "escapable character"++    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'++-- | 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)

@@ -10,20 +10,14 @@   , 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)+import qualified Data.ByteString.Short as BS  -- | 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@@ -66,40 +60,5 @@   {-# 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 == '_'

@@ -21,8 +21,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DNS.Pattern   ( -- * Pattern language-    DomainPattern-  , LabelPattern+    DomainPattern(..)+  , LabelPattern(..)   , matchesPattern   , patternWorksInside   , labelMatchesPattern@@ -39,10 +39,15 @@   ) where +import           Data.Char (isDigit, isLower, isUpper, ord) import           Data.Foldable (asum)+import           GHC.Word (Word8)  import           Control.Applicative.Combinators+import           Data.Attoparsec.Text as A ((<?>)) import qualified Data.Attoparsec.Text as A+import           Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Short as BS import qualified Data.Text as T  import           Network.DNS@@ -80,13 +85,13 @@  {-# INLINE buildLabelPattern #-} buildLabelPattern :: LabelPattern -> DList Char-buildLabelPattern (DomLiteral d) = buildLabel d+buildLabelPattern (DomLiteral d) = buildLit_ (getDomainLabel d) buildLabelPattern DomGlob        = singleton '*' buildLabelPattern DomGlobStar    = toDList "**"  {-# INLINE buildLabelPatternCF #-} buildLabelPatternCF :: LabelPattern -> DList Char-buildLabelPatternCF (DomLiteral d) = buildLabelCF d+buildLabelPatternCF (DomLiteral d) = buildLit_ (getDomainLabelCF d) buildLabelPatternCF DomGlob        = singleton '*' buildLabelPatternCF DomGlobStar    = toDList "**" @@ -137,16 +142,78 @@                 ]   where     litGlobStar :: A.Parser LabelPattern-    litGlobStar = asum [ DomLiteral <$> domainLabelP+    litGlobStar = asum [ DomLiteral <$> litPatternP                        , DomGlobStar <$ A.string "**"                        , DomGlob <$ A.char '*'                        ]      litGlob :: A.Parser LabelPattern-    litGlob = asum [ DomLiteral <$> domainLabelP+    litGlob = asum [ DomLiteral <$> litPatternP                    , DomGlob <$ A.char '*'                    ]  -- | Parse a domain pattern. Convenience wrapper for 'patternP. parsePattern :: T.Text -> Either String DomainPattern parsePattern = A.parseOnly (patternP <* A.endOfInput)++-- | Predicate selecting characters allowed in a literal domain pattern.+{-# INLINABLE isLitChar #-}+isLitChar :: Char -> Bool+isLitChar x = isLower x || isDigit x || isUpper x || x == '-' || x == '_'++-- | Variant of 'domainLabelP' that does not admit unescaped asterisk.+litPatternP :: A.Parser DomainLabel+litPatternP = mkDomainLabel . BS.pack <$> (some labelChar)+  where+    labelChar :: A.Parser Word8+    labelChar = do+        c <- A.satisfy (\x -> isLitChar x || x == '\\') <?> "domain label character"+        case c of+            '\\' -> escape+            _    -> pure (c2w c)++    escape :: A.Parser Word8+    escape = asum [ c2w <$> A.char '.'+                  , c2w <$> A.char '\\'+                  , c2w <$> A.char '*'+                  , octal ]+             <?> "escapable character"++    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'++-- | Make a case-folded string from a 'DomainLabel' suitable for pretty printing+{-# INLINE buildLit_ #-}+buildLit_ :: BS.ShortByteString -> DList Char+buildLit_ bs = toDList (replace (BS.unpack bs))+  where+    {-# INLINE replace #-}+    replace :: [Word8] -> [Char]+    replace (x:xs) = case x of+      _ | isLitChar (w2c x) -> (w2c x) : replace xs++      0x2a -> '\\' : '*' : 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)

@@ -89,6 +89,14 @@                  (Right (Domain ["foo"]))                  (parseAbsDomain "foo.") +    , TestCase $ assertEqual "parse a label containing an asterisk "+                 (Right (Domain ["foo*bar"]))+                 (parseAbsDomain "foo*bar.")++    , TestCase $ assertEqual "parse a label containing just asterisk "+                 (Right (Domain ["*"]))+                 (parseAbsDomain "*.")+     , TestCase $ assertEqual "parse deeper absolute domains"                  (Right (Domain ["foo", "bar"]))                  (parseAbsDomain "foo.bar.")@@ -119,6 +127,14 @@      , TestCase $ assertBool "do not allow globstar in the right"                  (isLeft (parsePattern "foo.**."))++    , TestCase $ assertEqual "parse escaped asterisk into an asterisk literal"+                 (Right (DomainPattern [DomLiteral "*"]))+                 (parsePattern "\\*.")++    , TestCase $ assertEqual "parse escaped asterisk in infix position into a literal"+                 (Right (DomainPattern [DomLiteral "foo*bar"]))+                 (parsePattern "foo\\*bar.")      , TestCase $ assertEqual "allow complex patterns with everything"                  (Right (DomainPattern [ DomGlobStar