module Network.DNS
( Domain
, getDomain
, mkDomain
, mkDomain'
, DomainLabel
, getDomainLabel
, getDomainLabelCF
, mkDomainLabel
, unsafeMkDomainLabel
, unsafeSingletonDomainLabel
, foldCase
, foldCase_
, foldCaseLabel
, parseAbsDomain
, parseAbsDomainRelax
, parseDomainLabel
, absDomainP
, absDomainRelaxP
, domainLabelP
, pprDomain_
, pprDomain
, pprDomainCF
, pprDomainLabel
, pprDomainLabelCF
)
where
import Data.Char (isDigit, isLower, isUpper)
import Data.Coerce (coerce)
import Data.Word (Word8)
import Control.Applicative.Combinators
import Control.Monad (when)
import Data.ByteString.Internal (w2c)
import Data.Char (ord)
import Data.Foldable (asum)
import Data.Attoparsec.Text ((<?>))
import qualified Data.Attoparsec.Text as A
import Data.ByteString.Internal (c2w)
import qualified Data.ByteString.Short as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.DNS.Internal
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)
getDomain :: Domain -> [DomainLabel]
getDomain :: Domain -> [DomainLabel]
getDomain = Domain -> [DomainLabel]
coerce
mkDomain :: [DomainLabel] -> Domain
mkDomain :: [DomainLabel] -> Domain
mkDomain = [DomainLabel] -> Domain
coerce
mkDomain' :: [T.Text] -> Domain
mkDomain' :: [Text] -> Domain
mkDomain' [Text]
xs = [DomainLabel] -> Domain
mkDomain (ShortByteString -> DomainLabel
mkDomainLabel (ShortByteString -> DomainLabel)
-> (Text -> ShortByteString) -> Text -> DomainLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
BS.toShort (ByteString -> ShortByteString)
-> (Text -> ByteString) -> Text -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> DomainLabel) -> [Text] -> [DomainLabel]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs)
{-# INLINE getDomainLabel #-}
getDomainLabel :: DomainLabel -> BS.ShortByteString
getDomainLabel :: DomainLabel -> ShortByteString
getDomainLabel = DomainLabel -> ShortByteString
getDomainLabel_
{-# INLINE getDomainLabelCF #-}
getDomainLabelCF :: DomainLabel -> BS.ShortByteString
getDomainLabelCF :: DomainLabel -> ShortByteString
getDomainLabelCF = DomainLabel -> ShortByteString
getDomainLabelCF_
mkDomainLabel :: BS.ShortByteString -> DomainLabel
mkDomainLabel :: ShortByteString -> DomainLabel
mkDomainLabel ShortByteString
l = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel ShortByteString
l ((Word8 -> Word8) -> ShortByteString -> ShortByteString
sbsMap Word8 -> Word8
foldCase_ ShortByteString
l)
unsafeMkDomainLabel :: BS.ShortByteString -> DomainLabel
unsafeMkDomainLabel :: ShortByteString -> DomainLabel
unsafeMkDomainLabel ShortByteString
l = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel ShortByteString
l ShortByteString
l
unsafeSingletonDomainLabel :: Word8 -> DomainLabel
unsafeSingletonDomainLabel :: Word8 -> DomainLabel
unsafeSingletonDomainLabel Word8
l = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel (Word8 -> ShortByteString
sbsSingleton Word8
l) (Word8 -> ShortByteString
sbsSingleton Word8
l)
foldCase :: Domain -> Domain
foldCase :: Domain -> Domain
foldCase (Domain [DomainLabel]
ls) = [DomainLabel] -> Domain
Domain (DomainLabel -> DomainLabel
foldCaseLabel (DomainLabel -> DomainLabel) -> [DomainLabel] -> [DomainLabel]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DomainLabel]
ls)
{-# INLINE foldCaseLabel #-}
foldCaseLabel :: DomainLabel -> DomainLabel
foldCaseLabel :: DomainLabel -> DomainLabel
foldCaseLabel (DomainLabel ShortByteString
_l ShortByteString
cf) = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel ShortByteString
cf ShortByteString
cf
{-# INLINE foldCase_ #-}
foldCase_ :: Word8 -> Word8
foldCase_ :: Word8 -> Word8
foldCase_ Word8
w | Char -> Word8
c2w Char
'A' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
c2w Char
'Z'
= Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
0x20
| Bool
otherwise
= Word8
w
pprDomain :: Domain -> T.Text
pprDomain :: Domain -> Text
pprDomain (Domain [DomainLabel]
l) = String -> Text
T.pack (DList Char -> String
forall a. DList a -> [a]
fromDList DList Char
build)
where
build :: DList Char
build :: DList Char
build = (DomainLabel -> DList Char -> DList Char)
-> DList Char -> [DomainLabel] -> DList Char
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DomainLabel
x DList Char
buf -> DomainLabel -> DList Char
buildLabel DomainLabel
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 [DomainLabel]
l
pprDomain_ :: Domain -> T.Text
pprDomain_ :: Domain -> Text
pprDomain_ (Domain [DomainLabel]
ls) = [ShortByteString] -> Text
pprLabelsUtf16 (DomainLabel -> ShortByteString
getDomainLabel_ (DomainLabel -> ShortByteString)
-> [DomainLabel] -> [ShortByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DomainLabel]
ls)
pprDomainCF :: Domain -> T.Text
pprDomainCF :: Domain -> Text
pprDomainCF (Domain [DomainLabel]
l) = String -> Text
T.pack (DList Char -> String
forall a. DList a -> [a]
fromDList DList Char
build)
where
build :: DList Char
build :: DList Char
build = (DomainLabel -> DList Char -> DList Char)
-> DList Char -> [DomainLabel] -> DList Char
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DomainLabel
x DList Char
buf -> DomainLabel -> DList Char
buildLabelCF DomainLabel
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 [DomainLabel]
l
pprDomainLabel :: DomainLabel -> T.Text
pprDomainLabel :: DomainLabel -> Text
pprDomainLabel = String -> Text
T.pack (String -> Text) -> (DomainLabel -> String) -> DomainLabel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Char -> String
forall a. DList a -> [a]
fromDList (DList Char -> String)
-> (DomainLabel -> DList Char) -> DomainLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainLabel -> DList Char
buildLabel
pprDomainLabelCF :: DomainLabel -> T.Text
pprDomainLabelCF :: DomainLabel -> Text
pprDomainLabelCF = String -> Text
T.pack (String -> Text) -> (DomainLabel -> String) -> DomainLabel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Char -> String
forall a. DList a -> [a]
fromDList (DList Char -> String)
-> (DomainLabel -> DList Char) -> DomainLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainLabel -> DList Char
buildLabelCF
absDomainRelaxP :: A.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 (ShortByteString -> Int
BS.length (ShortByteString -> Int) -> [ShortByteString] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ShortByteString]
l') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ShortByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ShortByteString]
l'
where
l' :: [BS.ShortByteString]
l' :: [ShortByteString]
l' = DomainLabel -> ShortByteString
getDomainLabel (DomainLabel -> ShortByteString)
-> [DomainLabel] -> [ShortByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DomainLabel]
labels
absDomainP :: A.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
'.'
]
{-# INLINE isLabelChar #-}
isLabelChar :: Char -> Bool
isLabelChar :: Char -> Bool
isLabelChar Char
x = Char -> Bool
isLower Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char -> Bool
isUpper Char
x Bool -> Bool -> Bool
|| 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
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*'
domainLabelP :: A.Parser DomainLabel
domainLabelP :: Parser DomainLabel
domainLabelP = 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 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 :: A.Parser Word8
labelChar :: Parser Text Word8
labelChar = do
Char
c <- (Char -> Bool) -> Parser Text Char
A.satisfy (\Char
x -> Char -> Bool
isLabelChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') 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
escape
Char
_ -> Word8 -> Parser Text Word8
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
'\\'
, 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 :: 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 (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'
{-# INLINE buildLabelCF #-}
buildLabelCF :: DomainLabel -> DList Char
buildLabelCF :: DomainLabel -> DList Char
buildLabelCF = ShortByteString -> DList Char
buildLabel_ (ShortByteString -> DList Char)
-> (DomainLabel -> ShortByteString) -> DomainLabel -> DList Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainLabel -> ShortByteString
getDomainLabelCF_
{-# INLINE buildLabel #-}
buildLabel :: DomainLabel -> DList Char
buildLabel :: DomainLabel -> DList Char
buildLabel = ShortByteString -> DList Char
buildLabel_ (ShortByteString -> DList Char)
-> (DomainLabel -> ShortByteString) -> DomainLabel -> DList Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainLabel -> ShortByteString
getDomainLabel_
{-# INLINE buildLabel_ #-}
buildLabel_ :: BS.ShortByteString -> DList Char
buildLabel_ :: ShortByteString -> DList Char
buildLabel_ ShortByteString
bs = String -> DList Char
forall a. [a] -> DList a
toDList ([Word8] -> String
replace (ShortByteString -> [Word8]
BS.unpack ShortByteString
bs))
where
{-# INLINE replace #-}
replace :: [Word8] -> [Char]
replace :: [Word8] -> String
replace (Word8
x:[Word8]
xs) = case Word8
x of
Word8
_ | Char -> Bool
isLabelChar (Word8 -> Char
w2c Word8
x) -> (Word8 -> Char
w2c Word8
x) Char -> String -> String
forall a. a -> [a] -> [a]
: [Word8] -> String
replace [Word8]
xs
Word8
0x2e -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: [Word8] -> String
replace [Word8]
xs
Word8
0x5c -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: [Word8] -> String
replace [Word8]
xs
Word8
_ -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
o1 Char -> String -> String
forall a. a -> [a] -> [a]
: Char
o2 Char -> String -> String
forall a. a -> [a] -> [a]
: Char
o3 Char -> String -> String
forall a. a -> [a] -> [a]
: [Word8] -> String
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)