dns-patterns (empty) → 0.1
raw patch · 5 files changed
+636/−0 lines, 5 filesdep +HUnitdep +attoparsecdep +base
Dependencies added: HUnit, attoparsec, base, bytestring, dns-patterns, parser-combinators, text
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- dns-patterns.cabal +43/−0
- lib/Network/DNS/Pattern.hs +375/−0
- test/Spec.hs +202/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for dns-patterns++## 0.1 -- 2022-02-09++* Initial release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright (c) 2021 Victor Nawothnig++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ dns-patterns.cabal view
@@ -0,0 +1,43 @@+cabal-version: 3.0+name: dns-patterns+version: 0.1+author: Victor Nawothnig+maintainer: Victor Nawothnig (dminuoso@icloud.com)+copyright: (c) 2022 Wobcom GmbH+bug-reports: https://gitlab.com/wobcom/haskell/dns-patterns+license: BSD-3-Clause+license-file: LICENSE+category: Network+description:+ See the main module "Network.DNS.Pattern" for full documentation++synopsis: DNS name parsing and pattern matching utilities+extra-source-files: CHANGELOG.md+++common all+ 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 }++library+ import: all+ exposed-modules: Network.DNS.Pattern+ build-depends: parser-combinators ^>= { 1.3.0 }+ hs-source-dirs: lib+ ghc-options: -Wall -Wcompat+ default-language: Haskell2010++test-suite tests+ import: all+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends: HUnit+ , dns-patterns+ hs-source-dirs: test+ default-language: Haskell2010++source-repository head+ type: git+ location: git@gitlab.com:wobcom/haskell/dns-patterns.git
+ lib/Network/DNS/Pattern.hs view
@@ -0,0 +1,375 @@+-- |+-- 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++ -- * 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.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+--+-- @+-- \\* gives an asterisk inside a label, rather than a glob/globstar.+-- @+--+--+-- Note: Currently a globstar is only supported on the left-most label.+--+-- Examples or valid patterns are:+--+-- @+-- *.foo.bar.+-- **.foo.bar.+-- foo.*.bar.+-- foo.bar.*.+-- @+++type Parser = A.Parser++-- | A domain pattern.+newtype DomainPattern = DomainPattern+ { getDomainPattern :: [LabelPattern]+ } deriving (Eq, Ord)++-- | 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)++-- | 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 }+ deriving (Ord)++instance Eq DomainLabel where+ DomainLabel l == DomainLabel r =+ BS.map caseFold l == BS.map caseFold r+ where+ caseFold :: Word8 -> Word8+ caseFold 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.+--+-- This function nearly roundtrips with 'parsePattern' in the sense that octet escape sequences might change case or drop a leading zero.+--+-- prop> parsePattern . pprPattern ~~~ id+pprPattern :: DomainPattern -> T.Text+pprPattern (DomainPattern l) = TL.toStrict (TB.toLazyText build)+ where+ build :: TB.Builder+ build = foldl' (\buf x -> buf <> buildLabelPattern x <> ".") mempty l++buildLabel :: DomainLabel -> TB.Builder+buildLabel (DomainLabel d) = BS.foldl' (\buf x -> buf <> go x) mempty d+ where+ go :: Word8 -> TB.Builder+ go 0x2e = "\\."+ go 0x5c = "\\\\"+ go c | c > 0x20+ && c <= 0x7E+ = TB.singleton (w2c c)++ | otherwise+ = "\\" <> TB.fromString (printf "%03o" c)++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)++ | otherwise+ = "\\" <> TB.fromString (printf "%03o" c)+buildLabelPattern DomGlob = "*"+buildLabelPattern DomGlobStar = "**"++-- | 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)++-- | Given a pattern and a DNS zone specified by a domain name, test whether or not the pattern+-- is applicable beneath that zone.+--+-- @+-- foo.*.bar. applicable inside zone quux.bar.+-- foo.bar. applicable inside zone bar.+-- bar. applicable inside zone bar.+-- foo.bar. not applicable inside zone quux.+-- @+patternWorksInside :: DomainPattern -> Domain -> Bool+patternWorksInside (DomainPattern x) (Domain y) = go (reverse x) (reverse y)+ where+ go :: [LabelPattern] -> [DomainLabel] -> Bool+ go [DomGlobStar] _ = True+ go [] [] = True+ go [] _ls = False+ go _p [] = True+ go (p:ps) (l:ls) = labelMatchesPattern (getDomainLabel l) p && go ps ls++-- | Test whether a given domain matches a 'DomainPattern'+matchesPattern :: Domain -> DomainPattern -> Bool+matchesPattern (Domain x) (DomainPattern y) = go (reverse x) (reverse y)+ where+ go :: [DomainLabel] -> [LabelPattern] -> Bool+ go [] [] = True+ go [] _ps = False+ go _ls [] = False+ go _ls [DomGlobStar] = True+ go (l:ls) (p:ps) = labelMatchesPattern (getDomainLabel l) p && go ls ps++-- | Test whether a single label matches a label pattern+labelMatchesPattern :: BS.ByteString -> 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+patternP = asum [ do p <- litGlobStar <* A.char '.'+ ps <- litGlob `endBy` A.char '.'+ pure (DomainPattern (p:ps))++ , DomainPattern [] <$ A.char '.' -- Literal pattern of the root domain "."+ ]+ where+ litGlobStar :: Parser LabelPattern+ litGlobStar = asum [ DomLiteral <$> patternLabelP+ , DomGlobStar <$ A.string "**"+ , DomGlob <$ A.char '*'+ ]++ litGlob :: Parser LabelPattern+ litGlob = asum [ DomLiteral <$> patternLabelP+ , 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 '.'++-- | 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"
+ test/Spec.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE OverloadedStrings #-}+module Main++where++import Data.Coerce (coerce)+import Data.String++import qualified Data.ByteString as BS+import qualified Data.Text as T+import Test.HUnit.Base+import Test.HUnit.Text++import Network.DNS.Pattern++instance IsString DomainPattern where+ fromString s = case parsePattern (T.pack s) of+ Right s -> s+ Left err -> error ("DomPat: no parse, " <> err)++instance IsString DomainLabel where+ fromString s = case parseDomainLabel (T.pack s) of+ Right s -> s+ Left err -> error ("DomainLabel: no parse, " <> err)++instance IsString Domain where+ fromString s = case parseAbsDomain (T.pack s) of+ Right s -> s+ Left err -> error ("Domain: no parse, " <> err)++instance Show Domain where+ showsPrec _ d = mappend (T.unpack (pprDomain d))++instance Show DomainPattern where+ showsPrec _ d = mappend (T.unpack (pprPattern d))++main :: IO ()+main = do+ runTestTTAndExit $ TestList+ [ patternMatchSpecs+ , patternParseSpecs+ , equalitySpecs+ , patternContainedSpecs+ , pprRoundTrips+ ]+++equalitySpecs :: Test+equalitySpecs = TestList+ [ TestCase $ assertEqual "case-fold ASCII characters for comparison"+ (Right True)+ (do l <- parseAbsDomain "foo."+ r <- parseAbsDomain "Foo."+ pure (l == r)+ )++ , TestCase $ assertEqual "do not case-fold ASCII characters in the latin-supplement"+ (Right False)+ (do l <- parseAbsDomain "\\335."+ r <- parseAbsDomain "\\375."+ pure (l == r)+ )+ ]++parseDomainSpecs :: Test+parseDomainSpecs = TestList+ [ TestCase $ assertBool "do not parse relative domains"+ (isLeft (parseAbsDomain "foo"))++ , TestCase $ assertBool "do not parse deeper relative domains"+ (isLeft (parseAbsDomain "foo.bar"))++ , TestCase $ assertEqual "parse simple absolute domains"+ (Right (Domain ["foo"]))+ (parseAbsDomain "foo.")++ , TestCase $ assertEqual "parse deeper absolute domains"+ (Right (Domain ["foo", "bar"]))+ (parseAbsDomain "foo.bar.")++ , TestCase $ assertEqual "parse domains with arbitrary bytes"+ (Right (Domain ["\\000", "\\777"]))+ (parseAbsDomain "\\000.\\777.")++ , TestCase $ assertBool "parse domains with 63 octets labels"+ (isRight (parseAbsDomain (T.pack (replicate 63 '1' <> "."))))++ , TestCase $ assertBool "do not parse domains with labels longer than 63 octets"+ (isLeft (parseAbsDomain (T.pack (replicate 64 '1' <> "."))))++ , TestCase $ assertEqual "parses relative domains in relaxed mode"+ (Right (Domain ["foo", "bar"]))+ (parseAbsDomainRelax "foo.bar")+ ]++patternParseSpecs :: Test+patternParseSpecs = TestList+ [ TestCase $ assertBool "do not allow globstar in the middle"+ (isLeft (parsePattern "foo.**.bar."))++ , TestCase $ assertBool "do not allow globstar in the right"+ (isLeft (parsePattern "foo.**."))++ , TestCase $ assertEqual "allow complex patterns with everything"+ (Right (DomainPattern [ DomGlobStar+ , DomLiteral "quux"+ , DomGlob+ , DomLiteral "foo"+ , DomLiteral "bar"]))+ (parsePattern "**.quux.*.foo.bar.")++ , TestCase $ assertEqual "allow simple literal pattern"+ (Right (DomainPattern [DomLiteral "foo"]))+ (parsePattern "foo.")++ , TestCase $ assertBool "do not allow relative domain patterns"+ (isLeft (parsePattern "foo"))++ , TestCase $ assertBool "do not allow empty domain patterns"+ (isLeft (parsePattern ""))++ , TestCase $ assertEqual "allow a top-level globstar pattern"+ (Right (DomainPattern [DomGlobStar]))+ (parsePattern "**.")++ , TestCase $ assertEqual "allow a top-level glob pattern"+ (Right (DomainPattern [DomGlob]))+ (parsePattern "*.")++ , TestCase $ assertEqual "allow a simple root pattern"+ (Right (DomainPattern []))+ (parsePattern ".")++ , TestCase $ assertEqual "allow escapable characters in patterns"+ (parsePattern "\\..\\*.\\\\.")+ (Right (DomainPattern [ DomLiteral "."+ , DomLiteral "*"+ , DomLiteral "\\" ]))++ , TestCase $ assertBool "Does not allow unescaped asterisk"+ (isLeft (parsePattern "a*."))++ , TestCase $ assertBool "Does not allow unesacped escape character with non-escapable character"+ (isLeft (parsePattern "a\\a."))++ , TestCase $ assertBool "does not allow octets other than non-ascii codepoints in patterns"+ (isLeft (parsePattern "\000.\777."))+ ]++isRight :: Either a b -> Bool+isRight Right{} = True+isRight _ = True++isLeft :: Either a b -> Bool+isLeft Left{} = True+isLeft _ = False+++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))++ , TestCase $ assertEqual "domains roundtrip between parse and ppr"+ (Right True)+ (do let input = "**.*\\000.foo."+ r <- parseAbsDomain input+ pure (pprDomain r == input))++ ]++patternMatchSpecs :: Test+patternMatchSpecs = TestList+ [ ("." `matchesPattern` ".") ~? "Matches literal of the root"+ , ("foo.bar." `matchesPattern` "foo.bar.") ~? "Matches literal"+ , not ("bar." `matchesPattern` "foo.bar.") ~? "Does not match literal"++ , ("foo.sub.bar." `matchesPattern` "foo.*.bar.") ~? "Matches glob"+ , not ("foo.sub.quux." `matchesPattern` "foo.*.bar.") ~? "Does not match glob"+ , not ("sub.quux." `matchesPattern` "*.bar.") ~? "Does not match glob"+++ , ("sub.foo.bar." `matchesPattern` "*.foo.bar.") ~? "Matches glob"+ , not ("sub.foo.quux." `matchesPattern` "*.foo.bar.") ~? "Does not match glob"+ , not ("sub2.sub1.foo.quux." `matchesPattern` "*.foo.bar.") ~? "Does not match glob"++ , ("sub1.foo.bar." `matchesPattern` "**.foo.bar.") ~? "Matches globstar"+ , ("sub2.sub2.foo.bar." `matchesPattern` "**.foo.bar.") ~? "Matches globstar"+ , not ("sub1.foo.quux." `matchesPattern` "**.foo.bar.") ~? "Does not match globstar"++ ]++patternContainedSpecs :: Test+patternContainedSpecs = TestList+ [ TestCase $ assertBool "t1" ("foo.*.bar." `patternWorksInside` "quux.bar.")+ , TestCase $ assertBool "t2" ("foo.bar." `patternWorksInside` "bar.")+ , TestCase $ assertBool "t3" ("bar." `patternWorksInside` "bar.")+ , TestCase $ assertBool "t4" (not ("foo.bar." `patternWorksInside` "quux."))+ ]