-- |
-- Module      : Network.DNS
-- Description : Generic DNS utilities
--
-- 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 the following subset of ASCII is acceptable per label:
-- [a-z], [A-Z], [0-9], '_', '-', '*'
--
-- Punycoding, if desired, must be taken care of the user.
--
-- In addition, we allow a backslash to be used as an escaping character for the following possible sequences:
--
-- 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@
module Network.DNS
  ( Domain
  , getDomain
  , mkDomain
  , mkDomain'
  , DomainLabel
  , getDomainLabel
  , getDomainLabelCF
  , mkDomainLabel
  , unsafeMkDomainLabel
  , unsafeSingletonDomainLabel
  , foldCase
  , foldCase_
  , foldCaseLabel

  -- * Parsing
  , parseAbsDomain
  , parseAbsDomainRelax
  , parseDomainLabel
  , absDomainP
  , absDomainRelaxP
  , domainLabelP

  -- * Pretty printing
  , 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

-- | 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)

-- | Turn a 'Domain' into a list of its labels.
--
-- prop> getDomain . mkDomain ~~~ id
-- prop> mkDomain . getDomain ~~~ id
getDomain :: Domain -> [DomainLabel]
getDomain :: Domain -> [DomainLabel]
getDomain = Domain -> [DomainLabel]
coerce

-- | Turn a list of labels into a 'Domain'.
--
-- prop> getDomain . mkDomain ~~~ id
-- prop> mkDomain . getDomain ~~~ id
mkDomain :: [DomainLabel] -> Domain
mkDomain :: [DomainLabel] -> Domain
mkDomain = [DomainLabel] -> Domain
coerce

-- | Turn a list of text labels into a 'Domain'
--
-- Codepoints outside ASCII are officially not supported.
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)

-- | Get the wire-representation of a domain label.
{-# INLINE getDomainLabel #-}
getDomainLabel :: DomainLabel -> BS.ShortByteString
getDomainLabel :: DomainLabel -> ShortByteString
getDomainLabel = DomainLabel -> ShortByteString
getDomainLabel_

-- | Get the [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3) case-folded wire-representation of a domain label.
{-# INLINE getDomainLabelCF #-}
getDomainLabelCF :: DomainLabel -> BS.ShortByteString
getDomainLabelCF :: DomainLabel -> ShortByteString
getDomainLabelCF = DomainLabel -> ShortByteString
getDomainLabelCF_

-- | Smart constructor for 'DomainLabel'
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)

-- | Unsafely construct a 'DomainLabel'. The argument must already be case-folded according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
unsafeMkDomainLabel :: BS.ShortByteString -> DomainLabel
unsafeMkDomainLabel :: ShortByteString -> DomainLabel
unsafeMkDomainLabel ShortByteString
l = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel ShortByteString
l ShortByteString
l


-- | Unsafely construct a 'DomainLabel' from a single Word8. The argument must already be case-folded according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
unsafeSingletonDomainLabel :: Word8 -> DomainLabel
unsafeSingletonDomainLabel :: Word8 -> DomainLabel
unsafeSingletonDomainLabel Word8
l = ShortByteString -> ShortByteString -> DomainLabel
DomainLabel (Word8 -> ShortByteString
sbsSingleton Word8
l) (Word8 -> ShortByteString
sbsSingleton Word8
l)

-- | Case-folding of a domain according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
-- Note 'Domain' will memoize a case-folded variant for 'Eq', 'Ord' and pretty printing already. This function is not useful to most.
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)

-- | Case-folding of a domain label according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
-- Note 'DomainLabel' will memoize a case-folded variant for 'Eq', 'Ord' and pretty printing already. This function is not useful to most.
{-# 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

-- | Print an arbitrary domain into a presentation format.
--
-- This function nearly roundtrips with 'parseAbsDomain' up to escape sequence equivalence
--
-- prop> parseAbsDomain . pprDomain ~~~ id
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)

-- | Print an arbitrary domain into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
--
-- This function nearly roundtrips with 'parseAbsDomain' up to escape sequence equivalence and case folding.
--
-- prop> parseAbsDomain . pprDomainCF ~~~ id
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

-- | Print a singular domain label into a presentation format.
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

-- | Print a singular domain label into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
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


-- | Attoparsec 'A.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 ends in a dot.
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
'.')

-- | 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 (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

-- | Attoparsec 'A.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 :: 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
'.' -- The root domain itself
        ]

-- | Predicate selecting characters allowed in a domain label without escaping.
{-# 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
'*'

-- | Attoparsec 'A.Parser' for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'.
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'

-- | Make a case-folded string from a 'DomainLabel' suitable for pretty printing
{-# 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_

-- | Make a string from a 'DomainLabel' suitable for pretty printing
{-# 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)