Pattern.hs

-- |
-- Module      : Network.DNS.Pattern
-- Description : DNS pattern matching
--
-- 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 of valid patterns are:
--
-- @
--    *.foo.bar.
--    **.foo.bar.
--    foo.*.bar.
--    foo.bar.*.
-- @

{-# LANGUAGE OverloadedStrings #-}
module Network.DNS.Pattern
  ( -- * Pattern language
    DomainPattern
  , LabelPattern
  , matchesPattern
  , patternWorksInside
  , labelMatchesPattern

  -- * Parsing
  , parsePattern
  , patternP

  -- * Pretty printing
  , pprPattern
  , pprPatternCF
  , pprLabelPattern
  , pprLabelPatternCF
  )
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
import           Network.DNS.Internal
import           Network.DNS.Pattern.Internal


-- | Print domain pattern.
--
-- This function nearly roundtrips with 'parsePattern' up to escape sequence equivalence.
--
-- prop> parsePattern . pprPattern ~~~ id
pprPattern :: DomainPattern -> T.Text
pprPattern (DomainPattern l) = T.pack (fromDList build)
  where
    build = foldr (\x buf -> buildLabelPattern x <> singleton '.' <> buf) mempty l

-- | 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
    build = foldr (\x buf -> buildLabelPatternCF x <> singleton '.' <> buf) mempty l

-- | Print a singular domain label pattern into a presentation format.
pprLabelPattern :: LabelPattern -> T.Text
pprLabelPattern = T.pack . fromDList . buildLabelPattern

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

{-# INLINE buildLabelPattern #-}
buildLabelPattern :: LabelPattern -> DList Char
buildLabelPattern (DomLiteral d) = buildLit_ (getDomainLabel d)
buildLabelPattern DomGlob        = singleton '*'
buildLabelPattern DomGlobStar    = toDList "**"

{-# INLINE buildLabelPatternCF #-}
buildLabelPatternCF :: LabelPattern -> DList Char
buildLabelPatternCF (DomLiteral d) = buildLit_ (getDomainLabelCF 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.
--
-- @
--   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 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 l p && go ls ps

-- | Test whether a single label matches a label pattern
labelMatchesPattern :: DomainLabel -> LabelPattern -> Bool
labelMatchesPattern _l DomGlob        = True
labelMatchesPattern  l (DomLiteral p) = l == p
labelMatchesPattern _l DomGlobStar    = True


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

                , DomainPattern [] <$ A.char '.' -- Literal pattern of the root domain "."
                ]
  where
    litGlobStar :: A.Parser LabelPattern
    litGlobStar = asum [ DomLiteral <$> litPatternP
                       , DomGlobStar <$ A.string "**"
                       , DomGlob <$ A.char '*'
                       ]

    litGlob :: A.Parser LabelPattern
    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)