Internal.hs

-- |
-- Module      : Network.DNS.Pattern.Internal
-- Description : Internal DNS types and definitions
--
-- This module is not part of public API and may change even between patch versions.

module Network.DNS.Internal
  ( DomainLabel(..)
  , Domain(..)
  , DList(..)
  , toDList
  , fromDList
  , buildLabel
  , buildLabelCF
  , singleton
  , isLabelChar
  )

where

import           Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Short as BS
import           Data.Function (on)
import           GHC.Word (Word8(..))

import           Data.Char (isDigit, isLower, isUpper)

-- | Domain label with case-insensitive 'Eq' and 'Ord' as per [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).
data DomainLabel = DomainLabel { getDomainLabel_ :: !BS.ShortByteString
                               , getDomainLabelCF_ :: !BS.ShortByteString }

-- | A domain parsed into labels. Each label is a 'BS.ShortByteString' 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 [DomainLabel] deriving (Eq, Ord)

instance Ord DomainLabel where
  (<=) = (<=) `on` getDomainLabelCF_
  compare = compare `on` getDomainLabelCF_

instance Eq DomainLabel where
  (==) = (==) `on` getDomainLabelCF_

-- | Difference list à la Huhges
newtype DList a = DList ([a] -> [a])

-- | Turn a list into 'DList'
{-# INLINE toDList #-}
toDList :: [a] -> DList a
toDList = DList . (++)

-- | Turn 'DList' back into a list.
{-# INLINE fromDList #-}
fromDList :: DList a -> [a]
fromDList (DList dl) = dl []

-- | Create a 'DList' containing just the specified element
{-# INLINE singleton #-}
singleton :: a -> DList a
singleton = DList . (:)

instance Semigroup (DList a) where
  {-# INLINE (<>) #-}
  DList l <> DList r = DList (l . r)

instance Monoid (DList a) where
  {-# INLINE mempty #-}
  mempty = DList id

-- | Make a case-folded string from a 'DomainLabel' suitable for pretty printing
{-# INLINE buildLabelCF #-}
buildLabelCF :: DomainLabel -> DList Char
buildLabelCF = buildLabel_ . getDomainLabelCF_

-- | Make a string from a 'DomainLabel' suitable for pretty printing
{-# INLINE buildLabel #-}
buildLabel :: DomainLabel -> DList Char
buildLabel = buildLabel_ . getDomainLabel_

{-# INLINE buildLabel_ #-}
buildLabel_ :: BS.ShortByteString -> DList Char
buildLabel_ bs = toDList (replace (BS.unpack bs))
  where
    {-# INLINE replace #-}
    replace :: [Word8] -> [Char]
    replace (x:xs) = case x of
      _ | isLabelChar (w2c x)
           -> (w2c x) : replace xs

      0x2e -> '\\' : '.' : replace xs
      0x5c -> '\\' : '\\' : replace xs
      _    -> '\\' : o1 : o2 : o3 : replace xs
        where
            (o1, o2, o3) = case quotRem x 8 of
                (v1, r3) -> case quotRem v1 8 of
                    (v2, r2) -> case quotRem v2 8 of
                        (_, r1)  -> (showD r1, showD r2, showD r3)
    replace [] = []
    {-# INLINE showD #-}
    showD :: Word8 -> Char
    showD x = w2c (x + 0x30)

-- | Predicate selecting characters allowed in a domain label without escaping.
{-# INLINABLE isLabelChar #-}
isLabelChar :: Char -> Bool
isLabelChar x = isLower x || isDigit x || isUpper x || x == '-' || x == '_'