-- |
-- 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 -> Text
pprPattern (DomainPattern [LabelPattern]
l) = [Char] -> Text
T.pack (DList Char -> [Char]
forall a. DList a -> [a]
fromDList DList Char
build)
  where
    build :: DList Char
build = (LabelPattern -> DList Char -> DList Char)
-> DList Char -> [LabelPattern] -> DList Char
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LabelPattern
x DList Char
buf -> LabelPattern -> DList Char
buildLabelPattern LabelPattern
x DList Char -> DList Char -> DList Char
forall a. Semigroup a => a -> a -> a
<> Char -> DList Char
forall a. a -> DList a
singleton Char
'.' DList Char -> DList Char -> DList Char
forall a. Semigroup a => a -> a -> a
<> DList Char
buf) DList Char
forall a. Monoid a => a
mempty [LabelPattern]
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 -> Text
pprPatternCF (DomainPattern [LabelPattern]
l) = [Char] -> Text
T.pack (DList Char -> [Char]
forall a. DList a -> [a]
fromDList DList Char
build)
  where
    build :: DList Char
build = (LabelPattern -> DList Char -> DList Char)
-> DList Char -> [LabelPattern] -> DList Char
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LabelPattern
x DList Char
buf -> LabelPattern -> DList Char
buildLabelPatternCF LabelPattern
x DList Char -> DList Char -> DList Char
forall a. Semigroup a => a -> a -> a
<> Char -> DList Char
forall a. a -> DList a
singleton Char
'.' DList Char -> DList Char -> DList Char
forall a. Semigroup a => a -> a -> a
<> DList Char
buf) DList Char
forall a. Monoid a => a
mempty [LabelPattern]
l

-- | Print a singular domain label pattern into a presentation format.
pprLabelPattern :: LabelPattern -> T.Text
pprLabelPattern :: LabelPattern -> Text
pprLabelPattern = [Char] -> Text
T.pack ([Char] -> Text)
-> (LabelPattern -> [Char]) -> LabelPattern -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Char -> [Char]
forall a. DList a -> [a]
fromDList (DList Char -> [Char])
-> (LabelPattern -> DList Char) -> LabelPattern -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelPattern -> DList Char
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 :: LabelPattern -> Text
pprLabelPatternCF = [Char] -> Text
T.pack ([Char] -> Text)
-> (LabelPattern -> [Char]) -> LabelPattern -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Char -> [Char]
forall a. DList a -> [a]
fromDList (DList Char -> [Char])
-> (LabelPattern -> DList Char) -> LabelPattern -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelPattern -> DList Char
buildLabelPatternCF

{-# INLINE buildLabelPattern #-}
buildLabelPattern :: LabelPattern -> DList Char
buildLabelPattern :: LabelPattern -> DList Char
buildLabelPattern (DomLiteral DomainLabel
d) = DomainLabel -> DList Char
buildLabel DomainLabel
d
buildLabelPattern LabelPattern
DomGlob        = Char -> DList Char
forall a. a -> DList a
singleton Char
'*'
buildLabelPattern LabelPattern
DomGlobStar    = [Char] -> DList Char
forall a. [a] -> DList a
toDList [Char]
"**"

{-# INLINE buildLabelPatternCF #-}
buildLabelPatternCF :: LabelPattern -> DList Char
buildLabelPatternCF :: LabelPattern -> DList Char
buildLabelPatternCF (DomLiteral DomainLabel
d) = DomainLabel -> DList Char
buildLabelCF DomainLabel
d
buildLabelPatternCF LabelPattern
DomGlob        = Char -> DList Char
forall a. a -> DList a
singleton Char
'*'
buildLabelPatternCF LabelPattern
DomGlobStar    = [Char] -> DList Char
forall a. [a] -> DList a
toDList [Char]
"**"

-- | 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 -> Domain -> Bool
patternWorksInside (DomainPattern [LabelPattern]
x) (Domain [DomainLabel]
y) = [LabelPattern] -> [DomainLabel] -> Bool
go ([LabelPattern] -> [LabelPattern]
forall a. [a] -> [a]
reverse [LabelPattern]
x) ([DomainLabel] -> [DomainLabel]
forall a. [a] -> [a]
reverse [DomainLabel]
y)
  where
    go :: [LabelPattern] -> [DomainLabel] -> Bool
    go :: [LabelPattern] -> [DomainLabel] -> Bool
go [LabelPattern
DomGlobStar] [DomainLabel]
_ = Bool
True
    go [] []           = Bool
True
    go [] [DomainLabel]
_ls          = Bool
False
    go [LabelPattern]
_p []           = Bool
True
    go (LabelPattern
p:[LabelPattern]
ps) (DomainLabel
l:[DomainLabel]
ls)   = DomainLabel -> LabelPattern -> Bool
labelMatchesPattern DomainLabel
l LabelPattern
p Bool -> Bool -> Bool
&& [LabelPattern] -> [DomainLabel] -> Bool
go [LabelPattern]
ps [DomainLabel]
ls

-- | Test whether a given domain matches a 'DomainPattern'
matchesPattern :: Domain -> DomainPattern -> Bool
matchesPattern :: Domain -> DomainPattern -> Bool
matchesPattern (Domain [DomainLabel]
x) (DomainPattern [LabelPattern]
y) = [DomainLabel] -> [LabelPattern] -> Bool
go ([DomainLabel] -> [DomainLabel]
forall a. [a] -> [a]
reverse [DomainLabel]
x) ([LabelPattern] -> [LabelPattern]
forall a. [a] -> [a]
reverse [LabelPattern]
y)
  where
    go :: [DomainLabel] -> [LabelPattern] -> Bool
    go :: [DomainLabel] -> [LabelPattern] -> Bool
go []   []            = Bool
True
    go []  [LabelPattern]
_ps            = Bool
False
    go [DomainLabel]
_ls  []            = Bool
False
    go [DomainLabel]
_ls  [LabelPattern
DomGlobStar] = Bool
True
    go (DomainLabel
l:[DomainLabel]
ls) (LabelPattern
p:[LabelPattern]
ps)      = DomainLabel -> LabelPattern -> Bool
labelMatchesPattern DomainLabel
l LabelPattern
p Bool -> Bool -> Bool
&& [DomainLabel] -> [LabelPattern] -> Bool
go [DomainLabel]
ls [LabelPattern]
ps

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


-- | Attoparsec 'A.Parser' for domain patterns. See 'parsePattern' for a convenince wrapper.
patternP :: A.Parser DomainPattern
patternP :: Parser DomainPattern
patternP = [Parser DomainPattern] -> Parser DomainPattern
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ do LabelPattern
p  <- Parser LabelPattern
litGlobStar Parser LabelPattern -> Parser Text Char -> Parser LabelPattern
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
A.char Char
'.'
                     [LabelPattern]
ps <- Parser LabelPattern
litGlob Parser LabelPattern
-> Parser Text Char -> Parser Text [LabelPattern]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
`endBy` Char -> Parser Text Char
A.char Char
'.'
                     DomainPattern -> Parser DomainPattern
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LabelPattern] -> DomainPattern
DomainPattern (LabelPattern
pLabelPattern -> [LabelPattern] -> [LabelPattern]
forall a. a -> [a] -> [a]
:[LabelPattern]
ps))

                , [LabelPattern] -> DomainPattern
DomainPattern [] DomainPattern -> Parser Text Char -> Parser DomainPattern
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
A.char Char
'.' -- Literal pattern of the root domain "."
                ]
  where
    litGlobStar :: A.Parser LabelPattern
    litGlobStar :: Parser LabelPattern
litGlobStar = [Parser LabelPattern] -> Parser LabelPattern
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ DomainLabel -> LabelPattern
DomLiteral (DomainLabel -> LabelPattern)
-> Parser Text DomainLabel -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text DomainLabel
domainLabelP
                       , LabelPattern
DomGlobStar LabelPattern -> Parser Text Text -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
A.string Text
"**"
                       , LabelPattern
DomGlob LabelPattern -> Parser Text Char -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
A.char Char
'*'
                       ]

    litGlob :: A.Parser LabelPattern
    litGlob :: Parser LabelPattern
litGlob = [Parser LabelPattern] -> Parser LabelPattern
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ DomainLabel -> LabelPattern
DomLiteral (DomainLabel -> LabelPattern)
-> Parser Text DomainLabel -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text DomainLabel
domainLabelP
                   , LabelPattern
DomGlob LabelPattern -> Parser Text Char -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
A.char Char
'*'
                   ]

-- | Parse a domain pattern. Convenience wrapper for 'patternP.
parsePattern :: T.Text -> Either String DomainPattern
parsePattern :: Text -> Either [Char] DomainPattern
parsePattern = Parser DomainPattern -> Text -> Either [Char] DomainPattern
forall a. Parser a -> Text -> Either [Char] a
A.parseOnly (Parser DomainPattern
patternP Parser DomainPattern -> Parser Text () -> Parser DomainPattern
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput)