-- |
-- 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 (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 -> 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 a b. (a -> b -> b) -> b -> [a] -> b
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 a b. (a -> b -> b) -> b -> [a] -> b
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) = ShortByteString -> DList Char
buildLit_ (DomainLabel -> ShortByteString
getDomainLabel 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) = ShortByteString -> DList Char
buildLit_ (DomainLabel -> ShortByteString
getDomainLabelCF 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 a b. Parser Text a -> Parser Text b -> Parser Text a
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 a. a -> Parser Text a
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 a b. a -> Parser Text b -> Parser Text a
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
litPatternP
                       , LabelPattern
DomGlobStar LabelPattern -> Parser Text Text -> Parser LabelPattern
forall a b. a -> Parser Text b -> Parser Text a
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 a b. a -> Parser Text b -> Parser Text a
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
litPatternP
                   , LabelPattern
DomGlob LabelPattern -> Parser Text Char -> Parser LabelPattern
forall a b. a -> Parser Text b -> Parser Text a
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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput)


-- | Variant of 'domainLabelP' that does not admit unescaped asterisk.
litPatternP :: A.Parser DomainLabel
litPatternP :: Parser Text DomainLabel
litPatternP = ShortByteString -> DomainLabel
mkDomainLabel (ShortByteString -> DomainLabel)
-> ([Word8] -> ShortByteString) -> [Word8] -> DomainLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
BS.pack ([Word8] -> DomainLabel)
-> Parser Text [Word8] -> Parser Text DomainLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Word8 -> Parser Text [Word8]
forall a. Parser Text a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text Word8
labelChar)
  where
    labelChar :: A.Parser Word8
    labelChar :: Parser Text Word8
labelChar = do
        Char
c <- (Char -> Bool) -> Parser Text Char
A.satisfy (\Char
x -> Word8 -> Bool
isLitChar (Char -> Word8
c2w Char
x) Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') Parser Text Char -> [Char] -> Parser Text Char
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"domain label character"
        case Char
c of
            Char
'\\' -> Parser Text Word8
escape
            Char
_    -> Word8 -> Parser Text Word8
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Word8
c2w Char
c)

    escape :: A.Parser Word8
    escape :: Parser Text Word8
escape = [Parser Text Word8] -> Parser Text Word8
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Char -> Word8
c2w (Char -> Word8) -> Parser Text Char -> Parser Text Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
A.char Char
'.'
                  , Char -> Word8
c2w (Char -> Word8) -> Parser Text Char -> Parser Text Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
A.char Char
'\\'
                  , Char -> Word8
c2w (Char -> Word8) -> Parser Text Char -> Parser Text Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
A.char Char
'*'
                  , Parser Text Word8
octal ]
             Parser Text Word8 -> [Char] -> Parser Text Word8
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"escapable character"

    octal :: A.Parser Word8
    octal :: Parser Text Word8
octal = do
        Int
o1 <- Char -> Int
v (Char -> Int) -> Parser Text Char -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
A.satisfy Char -> Bool
isOctal
        Int
o2 <- Char -> Int
v (Char -> Int) -> Parser Text Char -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
A.satisfy Char -> Bool
isOctal
        Int
o3 <- Char -> Int
v (Char -> Int) -> Parser Text Char -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
A.satisfy Char -> Bool
isOctal
        Word8 -> Parser Text Word8
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                            Int
o2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                            Int
o3))

        where
            v :: Char -> Int
v Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48

            isOctal :: Char -> Bool
            isOctal :: Char -> Bool
isOctal Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'7'

-- | Make a case-folded string from a 'DomainLabel' suitable for pretty printing
{-# INLINE buildLit_ #-}
buildLit_ :: BS.ShortByteString -> DList Char
buildLit_ :: ShortByteString -> DList Char
buildLit_ ShortByteString
bs = [Char] -> DList Char
forall a. [a] -> DList a
toDList ([Word8] -> [Char]
replace (ShortByteString -> [Word8]
BS.unpack ShortByteString
bs))
  where
    {-# INLINE replace #-}
    replace :: [Word8] -> [Char]
    replace :: [Word8] -> [Char]
replace (Word8
x:[Word8]
xs) = case Word8
x of
      Word8
_ | Word8 -> Bool
isLitChar Word8
x -> Word8 -> Char
w2c Word8
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs

      Word8
0x2a -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'*' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
      Word8
0x2e -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'.' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
      Word8
0x5c -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
      Word8
_    -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o2 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o3 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
        where
            (Char
o1, Char
o2, Char
o3) = case Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
quotRem Word8
x Word8
8 of
                (Word8
v1, Word8
r3) -> case Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
quotRem Word8
v1 Word8
8 of
                    (Word8
v2, Word8
r2) -> case Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
quotRem Word8
v2 Word8
8 of
                        (Word8
_, Word8
r1)  -> (Word8 -> Char
showD Word8
r1, Word8 -> Char
showD Word8
r2, Word8 -> Char
showD Word8
r3)
    replace [] = []
    {-# INLINE showD #-}
    showD :: Word8 -> Char
    showD :: Word8 -> Char
showD Word8
x = Word8 -> Char
w2c (Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
0x30)