-- |
-- 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
  { DomainPattern -> [LabelPattern]
getDomainPattern :: [LabelPattern]
  } deriving (DomainPattern -> DomainPattern -> Bool
(DomainPattern -> DomainPattern -> Bool)
-> (DomainPattern -> DomainPattern -> Bool) -> Eq DomainPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DomainPattern -> DomainPattern -> Bool
$c/= :: DomainPattern -> DomainPattern -> Bool
== :: DomainPattern -> DomainPattern -> Bool
$c== :: DomainPattern -> DomainPattern -> Bool
Eq, Eq DomainPattern
Eq DomainPattern
-> (DomainPattern -> DomainPattern -> Ordering)
-> (DomainPattern -> DomainPattern -> Bool)
-> (DomainPattern -> DomainPattern -> Bool)
-> (DomainPattern -> DomainPattern -> Bool)
-> (DomainPattern -> DomainPattern -> Bool)
-> (DomainPattern -> DomainPattern -> DomainPattern)
-> (DomainPattern -> DomainPattern -> DomainPattern)
-> Ord DomainPattern
DomainPattern -> DomainPattern -> Bool
DomainPattern -> DomainPattern -> Ordering
DomainPattern -> DomainPattern -> DomainPattern
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DomainPattern -> DomainPattern -> DomainPattern
$cmin :: DomainPattern -> DomainPattern -> DomainPattern
max :: DomainPattern -> DomainPattern -> DomainPattern
$cmax :: DomainPattern -> DomainPattern -> DomainPattern
>= :: DomainPattern -> DomainPattern -> Bool
$c>= :: DomainPattern -> DomainPattern -> Bool
> :: DomainPattern -> DomainPattern -> Bool
$c> :: DomainPattern -> DomainPattern -> Bool
<= :: DomainPattern -> DomainPattern -> Bool
$c<= :: DomainPattern -> DomainPattern -> Bool
< :: DomainPattern -> DomainPattern -> Bool
$c< :: DomainPattern -> DomainPattern -> Bool
compare :: DomainPattern -> DomainPattern -> Ordering
$ccompare :: DomainPattern -> DomainPattern -> Ordering
$cp1Ord :: Eq DomainPattern
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
  { Domain -> [DomainLabel]
getDomain :: [DomainLabel]
  } deriving (Domain -> Domain -> Bool
(Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool) -> Eq Domain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Domain -> Domain -> Bool
$c/= :: Domain -> Domain -> Bool
== :: Domain -> Domain -> Bool
$c== :: Domain -> Domain -> Bool
Eq, Eq Domain
Eq Domain
-> (Domain -> Domain -> Ordering)
-> (Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool)
-> (Domain -> Domain -> Domain)
-> (Domain -> Domain -> Domain)
-> Ord Domain
Domain -> Domain -> Bool
Domain -> Domain -> Ordering
Domain -> Domain -> Domain
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Domain -> Domain -> Domain
$cmin :: Domain -> Domain -> Domain
max :: Domain -> Domain -> Domain
$cmax :: Domain -> Domain -> Domain
>= :: Domain -> Domain -> Bool
$c>= :: Domain -> Domain -> Bool
> :: Domain -> Domain -> Bool
$c> :: Domain -> Domain -> Bool
<= :: Domain -> Domain -> Bool
$c<= :: Domain -> Domain -> Bool
< :: Domain -> Domain -> Bool
$c< :: Domain -> Domain -> Bool
compare :: Domain -> Domain -> Ordering
$ccompare :: Domain -> Domain -> Ordering
$cp1Ord :: Eq Domain
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 { DomainLabel -> ByteString
getDomainLabel :: BS.ByteString }
  deriving (Eq DomainLabel
Eq DomainLabel
-> (DomainLabel -> DomainLabel -> Ordering)
-> (DomainLabel -> DomainLabel -> Bool)
-> (DomainLabel -> DomainLabel -> Bool)
-> (DomainLabel -> DomainLabel -> Bool)
-> (DomainLabel -> DomainLabel -> Bool)
-> (DomainLabel -> DomainLabel -> DomainLabel)
-> (DomainLabel -> DomainLabel -> DomainLabel)
-> Ord DomainLabel
DomainLabel -> DomainLabel -> Bool
DomainLabel -> DomainLabel -> Ordering
DomainLabel -> DomainLabel -> DomainLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DomainLabel -> DomainLabel -> DomainLabel
$cmin :: DomainLabel -> DomainLabel -> DomainLabel
max :: DomainLabel -> DomainLabel -> DomainLabel
$cmax :: DomainLabel -> DomainLabel -> DomainLabel
>= :: DomainLabel -> DomainLabel -> Bool
$c>= :: DomainLabel -> DomainLabel -> Bool
> :: DomainLabel -> DomainLabel -> Bool
$c> :: DomainLabel -> DomainLabel -> Bool
<= :: DomainLabel -> DomainLabel -> Bool
$c<= :: DomainLabel -> DomainLabel -> Bool
< :: DomainLabel -> DomainLabel -> Bool
$c< :: DomainLabel -> DomainLabel -> Bool
compare :: DomainLabel -> DomainLabel -> Ordering
$ccompare :: DomainLabel -> DomainLabel -> Ordering
$cp1Ord :: Eq DomainLabel
Ord)

instance Eq DomainLabel where
  DomainLabel ByteString
l == :: DomainLabel -> DomainLabel -> Bool
== DomainLabel ByteString
r =
        (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
caseFold ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
caseFold ByteString
r
    where
        caseFold :: Word8 -> Word8
        caseFold :: Word8 -> Word8
caseFold Word8
x = case Word8
x of
            Word8
0x41 -> Char -> Word8
c2w Char
'a'
            Word8
0x42 -> Char -> Word8
c2w Char
'b'
            Word8
0x43 -> Char -> Word8
c2w Char
'c'
            Word8
0x44 -> Char -> Word8
c2w Char
'd'
            Word8
0x45 -> Char -> Word8
c2w Char
'e'
            Word8
0x46 -> Char -> Word8
c2w Char
'f'
            Word8
0x47 -> Char -> Word8
c2w Char
'g'
            Word8
0x48 -> Char -> Word8
c2w Char
'h'
            Word8
0x49 -> Char -> Word8
c2w Char
'i'
            Word8
0x4a -> Char -> Word8
c2w Char
'j'
            Word8
0x4b -> Char -> Word8
c2w Char
'k'
            Word8
0x4c -> Char -> Word8
c2w Char
'l'
            Word8
0x4d -> Char -> Word8
c2w Char
'm'
            Word8
0x4e -> Char -> Word8
c2w Char
'n'
            Word8
0x4f -> Char -> Word8
c2w Char
'o'
            Word8
0x50 -> Char -> Word8
c2w Char
'p'
            Word8
0x51 -> Char -> Word8
c2w Char
'q'
            Word8
0x52 -> Char -> Word8
c2w Char
'r'
            Word8
0x53 -> Char -> Word8
c2w Char
's'
            Word8
0x54 -> Char -> Word8
c2w Char
't'
            Word8
0x55 -> Char -> Word8
c2w Char
'u'
            Word8
0x56 -> Char -> Word8
c2w Char
'v'
            Word8
0x57 -> Char -> Word8
c2w Char
'w'
            Word8
0x58 -> Char -> Word8
c2w Char
'x'
            Word8
0x59 -> Char -> Word8
c2w Char
'y'
            Word8
0x5a -> Char -> Word8
c2w Char
'z'
            Word8
_    -> Word8
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 -> Text
pprDomain (Domain [DomainLabel]
l) = Text -> Text
TL.toStrict (Builder -> Text
TB.toLazyText Builder
build)
  where
    build :: TB.Builder
    build :: Builder
build = (Builder -> DomainLabel -> Builder)
-> Builder -> [DomainLabel] -> Builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Builder
buf DomainLabel
x -> Builder
buf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> DomainLabel -> Builder
buildLabel DomainLabel
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
".") Builder
forall a. Monoid a => a
mempty [DomainLabel]
l

-- | Print a singular domain label into a presentation format.
pprDomainLabel :: DomainLabel -> T.Text
pprDomainLabel :: DomainLabel -> Text
pprDomainLabel = Text -> Text
TL.toStrict (Text -> Text) -> (DomainLabel -> Text) -> DomainLabel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText (Builder -> Text)
-> (DomainLabel -> Builder) -> DomainLabel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainLabel -> Builder
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 -> Text
pprPattern (DomainPattern [LabelPattern]
l) = Text -> Text
TL.toStrict (Builder -> Text
TB.toLazyText Builder
build)
  where
    build :: TB.Builder
    build :: Builder
build = (Builder -> LabelPattern -> Builder)
-> Builder -> [LabelPattern] -> Builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Builder
buf LabelPattern
x -> Builder
buf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> LabelPattern -> Builder
buildLabelPattern LabelPattern
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
".") Builder
forall a. Monoid a => a
mempty [LabelPattern]
l

buildLabel :: DomainLabel -> TB.Builder
buildLabel :: DomainLabel -> Builder
buildLabel (DomainLabel ByteString
d) = (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Builder
buf Word8
x -> Builder
buf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
go Word8
x) Builder
forall a. Monoid a => a
mempty ByteString
d
  where
    go :: Word8 -> TB.Builder
    go :: Word8 -> Builder
go Word8
0x2e = Builder
"\\."
    go Word8
0x5c = Builder
"\\\\"
    go Word8
c | Word8
c  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0x20
         Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7E
         = Char -> Builder
TB.singleton (Word8 -> Char
w2c Word8
c)

         | Bool
otherwise
         = Builder
"\\" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString (String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
"%03o" Word8
c)

buildLabelPattern :: LabelPattern -> TB.Builder
buildLabelPattern :: LabelPattern -> Builder
buildLabelPattern (DomLiteral ByteString
d) = (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Builder
buf Word8
x -> Builder
buf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
go Word8
x) Builder
forall a. Monoid a => a
mempty ByteString
d
  where
    go :: Word8 -> TB.Builder
    go :: Word8 -> Builder
go Word8
0x2e = Builder
"\\."
    go Word8
0x5c = Builder
"\\\\"
    go Word8
0x2a = Builder
"\\*"
    go Word8
c |  Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>  Word8
0x20
         Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7E = Char -> Builder
TB.singleton (Word8 -> Char
w2c Word8
c)

         | Bool
otherwise
         = Builder
"\\" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString (String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
"%03o" Word8
c)
buildLabelPattern LabelPattern
DomGlob     = Builder
"*"
buildLabelPattern LabelPattern
DomGlobStar = Builder
"**"

-- | 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 (LabelPattern -> LabelPattern -> Bool
(LabelPattern -> LabelPattern -> Bool)
-> (LabelPattern -> LabelPattern -> Bool) -> Eq LabelPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabelPattern -> LabelPattern -> Bool
$c/= :: LabelPattern -> LabelPattern -> Bool
== :: LabelPattern -> LabelPattern -> Bool
$c== :: LabelPattern -> LabelPattern -> Bool
Eq, Eq LabelPattern
Eq LabelPattern
-> (LabelPattern -> LabelPattern -> Ordering)
-> (LabelPattern -> LabelPattern -> Bool)
-> (LabelPattern -> LabelPattern -> Bool)
-> (LabelPattern -> LabelPattern -> Bool)
-> (LabelPattern -> LabelPattern -> Bool)
-> (LabelPattern -> LabelPattern -> LabelPattern)
-> (LabelPattern -> LabelPattern -> LabelPattern)
-> Ord LabelPattern
LabelPattern -> LabelPattern -> Bool
LabelPattern -> LabelPattern -> Ordering
LabelPattern -> LabelPattern -> LabelPattern
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LabelPattern -> LabelPattern -> LabelPattern
$cmin :: LabelPattern -> LabelPattern -> LabelPattern
max :: LabelPattern -> LabelPattern -> LabelPattern
$cmax :: LabelPattern -> LabelPattern -> LabelPattern
>= :: LabelPattern -> LabelPattern -> Bool
$c>= :: LabelPattern -> LabelPattern -> Bool
> :: LabelPattern -> LabelPattern -> Bool
$c> :: LabelPattern -> LabelPattern -> Bool
<= :: LabelPattern -> LabelPattern -> Bool
$c<= :: LabelPattern -> LabelPattern -> Bool
< :: LabelPattern -> LabelPattern -> Bool
$c< :: LabelPattern -> LabelPattern -> Bool
compare :: LabelPattern -> LabelPattern -> Ordering
$ccompare :: LabelPattern -> LabelPattern -> Ordering
$cp1Ord :: Eq LabelPattern
Ord, Int -> LabelPattern -> ShowS
[LabelPattern] -> ShowS
LabelPattern -> String
(Int -> LabelPattern -> ShowS)
-> (LabelPattern -> String)
-> ([LabelPattern] -> ShowS)
-> Show LabelPattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LabelPattern] -> ShowS
$cshowList :: [LabelPattern] -> ShowS
show :: LabelPattern -> String
$cshow :: LabelPattern -> String
showsPrec :: Int -> LabelPattern -> ShowS
$cshowsPrec :: Int -> LabelPattern -> ShowS
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 -> 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)   = ByteString -> LabelPattern -> Bool
labelMatchesPattern (DomainLabel -> ByteString
getDomainLabel 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)      = ByteString -> LabelPattern -> Bool
labelMatchesPattern (DomainLabel -> ByteString
getDomainLabel 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 :: BS.ByteString -> LabelPattern -> Bool
labelMatchesPattern :: ByteString -> LabelPattern -> Bool
labelMatchesPattern ByteString
_l LabelPattern
DomGlob        = Bool
True
labelMatchesPattern  ByteString
l (DomLiteral ByteString
p) = ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
p
labelMatchesPattern ByteString
_l LabelPattern
DomGlobStar    = Bool
True


-- | Parser for domain patterns. See 'parsePattern' for a convenince wrapper.
patternP :: 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 :: Parser LabelPattern
    litGlobStar :: Parser LabelPattern
litGlobStar = [Parser LabelPattern] -> Parser LabelPattern
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ ByteString -> LabelPattern
DomLiteral (ByteString -> LabelPattern)
-> Parser Text ByteString -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ByteString
patternLabelP
                       , 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 :: Parser LabelPattern
    litGlob :: Parser LabelPattern
litGlob = [Parser LabelPattern] -> Parser LabelPattern
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ ByteString -> LabelPattern
DomLiteral (ByteString -> LabelPattern)
-> Parser Text ByteString -> Parser LabelPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ByteString
patternLabelP
                   , 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 String DomainPattern
parsePattern = Parser DomainPattern -> Text -> Either String DomainPattern
forall a. Parser a -> Text -> Either String 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)

-- | Parse an absolute domain. Convenience wrapper for 'absDomainP'.
parseAbsDomain :: T.Text -> Either String Domain
parseAbsDomain :: Text -> Either String Domain
parseAbsDomain = Parser Domain -> Text -> Either String Domain
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser Domain
absDomainP Parser Domain -> Parser Text () -> Parser Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput)

-- | Parse a singular domain label. Convenience wrapper for 'domainLabelP'.
parseDomainLabel :: T.Text -> Either String DomainLabel
parseDomainLabel :: Text -> Either String DomainLabel
parseDomainLabel = Parser DomainLabel -> Text -> Either String DomainLabel
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser DomainLabel
domainLabelP Parser DomainLabel -> Parser Text () -> Parser DomainLabel
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
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 :: Text -> Either String Domain
parseAbsDomainRelax = Parser Domain -> Text -> Either String Domain
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser Domain
absDomainRelaxP Parser Domain -> Parser Text () -> Parser Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
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 :: Parser Domain
absDomainRelaxP = do
    Domain
d <- Parser Domain
go
    let l :: Int
l = Domain -> Int
encodedLength Domain
d
    Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
255) (String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"domain name too long")
    Domain -> Parser Domain
forall (f :: * -> *) a. Applicative f => a -> f a
pure Domain
d

  where
    go :: Parser Domain
go = [DomainLabel] -> Domain
Domain ([DomainLabel] -> Domain)
-> Parser Text [DomainLabel] -> Parser Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DomainLabel
domainLabelP Parser DomainLabel -> Parser Text Char -> Parser Text [DomainLabel]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
`sepBy1` Char -> Parser Text Char
A.char Char
'.' Parser Domain -> Parser Text (Maybe Char) -> Parser Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
A.char Char
'.')

-- | Calculate the wire-encoded length of a domain name.
encodedLength :: Domain -> Int
encodedLength :: Domain -> Int
encodedLength (Domain [DomainLabel]
labels) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (ByteString -> Int
BS.length (ByteString -> Int) -> [ByteString] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
l') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
l'
  where
    l' :: [ByteString]
l' = [DomainLabel] -> [ByteString]
coerce [DomainLabel]
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 :: Parser Domain
absDomainP = do
    Domain
d <- Parser Domain
go
    let l :: Int
l = Domain -> Int
encodedLength Domain
d
    Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
255) (String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"domain name too long")
    Domain -> Parser Domain
forall (f :: * -> *) a. Applicative f => a -> f a
pure Domain
d

  where
    go :: Parser Domain
go = [DomainLabel] -> Domain
Domain ([DomainLabel] -> Domain)
-> Parser Text [DomainLabel] -> Parser Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser Text [DomainLabel]] -> Parser Text [DomainLabel]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Parser DomainLabel
domainLabelP Parser DomainLabel -> Parser Text Char -> Parser Text [DomainLabel]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
`endBy1` Char -> Parser Text Char
A.char Char
'.'
        , [] [DomainLabel] -> Parser Text Char -> Parser Text [DomainLabel]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
A.char Char
'.' -- The root domain itself
        ]

patternLabelP :: Parser BS.ByteString
patternLabelP :: Parser Text ByteString
patternLabelP = do
    ByteString
r <- [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> Parser Text [Word8] -> Parser Text ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Word8 -> Parser Text [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text Word8
labelChar)
    Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64) (String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"label must not be longer than 63 octets")
    ByteString -> Parser Text ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
r
  where
    labelChar :: Parser Word8
    labelChar :: Parser Text Word8
labelChar = do
        Char
c <- (Char -> Bool) -> Parser Text Char
A.satisfy (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.'
                           Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*'
                           Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x
                        ) Parser Text Char -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
<?> String
"pattern label character"
        case Char
c of
            Char
'\\' -> Parser Text Word8
escapable
            Char
_    -> Word8 -> Parser Text Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Word8
c2w Char
c)

    escapable :: Parser Word8
    escapable :: Parser Text Word8
escapable = [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 -> String -> Parser Text Word8
forall i a. Parser i a -> String -> Parser i a
<?> String
"escapable character"

octal :: 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 (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'

-- | Parser for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'.
domainLabelP :: Parser DomainLabel
domainLabelP :: Parser DomainLabel
domainLabelP = ByteString -> DomainLabel
DomainLabel (ByteString -> DomainLabel)
-> ([Word8] -> ByteString) -> [Word8] -> DomainLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> DomainLabel)
-> Parser Text [Word8] -> Parser DomainLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Word8 -> Parser Text [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text Word8
labelChar)
  where
    labelChar :: Parser Word8
    labelChar :: Parser Text Word8
labelChar = do
        Char
c <- (Char -> Bool) -> Parser Text Char
A.satisfy (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.'
                           Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x
                       ) Parser Text Char -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
<?> String
"domain label character"
        case Char
c of
            Char
'\\' -> Parser Text Word8
escapable
            Char
_    -> Word8 -> Parser Text Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Word8
c2w Char
c)

    escapable :: Parser Word8
    escapable :: Parser Text Word8
escapable = [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
'\\'
        , Parser Text Word8
octal
        ] Parser Text Word8 -> String -> Parser Text Word8
forall i a. Parser i a -> String -> Parser i a
<?> String
"escapable character"