DNS.hs

{-# LANGUAGE MagicHash #-}
-- |
-- 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:
--
-- @
--    \\.      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
  , DomainLabel
  , getDomainLabel
  , getDomainLabelCF
  , mkDomainLabel
  , unsafeMkDomainLabel
  , unsafeSingletonDomainLabel
  , foldCase
  , foldCaseLabel

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

  -- * Pretty printing
  , pprDomain
  , pprDomainCF
  , pprDomainLabel
  , pprDomainLabelCF
  )
where

import           Data.Coerce (coerce)
import           GHC.Exts (Addr#, indexWord8OffAddr#)
import           GHC.Int (Int(..))
import           GHC.Word (Word8(..))

import           Control.Applicative.Combinators
import           Control.Monad (when)
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           Network.DNS.Internal

-- | Parse an absolute domain. Convenience wrapper for 'absDomainP'.
parseAbsDomain :: T.Text -> Either String Domain
parseAbsDomain = A.parseOnly (absDomainP <* A.endOfInput)

-- | Parse a singular domain label. Convenience wrapper for 'domainLabelP'.
parseDomainLabel :: T.Text -> Either String DomainLabel
parseDomainLabel = A.parseOnly (domainLabelP <* 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 = A.parseOnly (absDomainRelaxP <* A.endOfInput)

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

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

-- | Get the wire-representation of a domain label.
{-# INLINE getDomainLabel #-}
getDomainLabel :: DomainLabel -> BS.ShortByteString
getDomainLabel = 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 = getDomainLabelCF_

-- | Smart constructor for 'DomainLabel'
mkDomainLabel :: BS.ShortByteString -> DomainLabel
mkDomainLabel l = DomainLabel l (BS.map foldCase_ 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 l = DomainLabel l 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 l = DomainLabel (BS.singleton l) (BS.singleton 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 ls) = Domain (foldCaseLabel <$> 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 _l cf) = DomainLabel cf cf

foldCase_ :: Word8 -> Word8
foldCase_ w = case fromIntegral w of
    I# n -> W8# (indexWord8OffAddr# table n)
  where
    table :: Addr#
    table = "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\
            \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\
            \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\
            \\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\
            \\x40\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\
            \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x5b\x5c\x5d\x5e\x5f\
            \\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\
            \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\
            \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\
            \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\
            \\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\
            \\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\
            \\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\
            \\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\
            \\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\
            \\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"#

-- | 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 l) = T.pack (fromDList build)
  where
    build :: DList Char
    build = foldr (\x buf -> buildLabel x <> singleton '.' <> buf) mempty l

-- | 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 l) = T.pack (fromDList build)
  where
    build :: DList Char
    build = foldr (\x buf -> buildLabelCF x <> singleton '.' <> buf) mempty l

-- | Print a singular domain label into a presentation format.
pprDomainLabel :: DomainLabel -> T.Text
pprDomainLabel = T.pack . fromDList . 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 = T.pack . fromDList . 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 = do
    d <- go
    let l = encodedLength d
    when (l >= 255) (fail "domain name too long")
    pure d

  where
    go = Domain <$> domainLabelP `sepBy1` A.char '.' <* optional (A.char '.')

-- | Calculate the wire-encoded length of a domain name.
encodedLength :: Domain -> Int
encodedLength (Domain labels) = sum (BS.length <$> l') + length l'
  where
    l' :: [BS.ShortByteString]
    l' = getDomainLabel <$> 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 = do
    d <- go
    let l = encodedLength d
    when (l >= 255) (fail "domain name too long")
    pure d

  where
    go = Domain <$> asum
        [ domainLabelP `endBy1` A.char '.'
        , [] <$ A.char '.' -- The root domain itself
        ]

octal :: A.Parser Word8
octal = do
  o1 <- v <$> A.satisfy isOctal
  o2 <- v <$> A.satisfy isOctal
  o3 <- v <$> A.satisfy isOctal
  pure (fromIntegral (o1 * 64 +
                      o2 * 8 +
                      o3))

  where
    v c = ord c - 48

    isOctal :: Char -> Bool
    isOctal c = c >= '0' && c <= '7'

-- | Attoparsec 'A.Parser' for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'.
domainLabelP :: A.Parser DomainLabel
domainLabelP = mkDomainLabel . BS.pack <$> (some labelChar)
  where
    labelChar :: A.Parser Word8
    labelChar = do
        c <- A.satisfy (\x -> isLabelChar x || x == '\\') <?> "domain label character"
        case c of
            '\\' -> escapable
            _    -> pure (c2w c)

    escapable :: A.Parser Word8
    escapable = asum
        [ c2w <$> A.char '.'
        , c2w <$> A.char '\\'
        , octal
        ] <?> "escapable character"