{-# LANGUAGE OverloadedStrings #-}
module Network.DNS.Pattern
(
parseAbsDomain
, parseAbsDomainRelax
, parseDomainLabel
, absDomainP
, absDomainRelaxP
, Domain(..)
, DomainLabel(..)
, pprDomain
, pprDomainLabel
, 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
type Parser = A.Parser
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)
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 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
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
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
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
"**"
data LabelPattern
= DomLiteral BS.ByteString
| DomGlob
| DomGlobStar
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)
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
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
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
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
'.'
]
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
'*'
]
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)
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)
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)
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)
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
'.')
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]
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
'.'
]
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'
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"