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.Foldable (asum)

import           Control.Applicative.Combinators
import qualified Data.Attoparsec.Text as A
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) = buildLabel d
buildLabelPattern DomGlob        = singleton '*'
buildLabelPattern DomGlobStar    = toDList "**"

{-# 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.
--
-- @
--   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 <$> domainLabelP
                       , DomGlobStar <$ A.string "**"
                       , DomGlob <$ A.char '*'
                       ]

    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)