-- |
-- 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 { DomainLabel -> ShortByteString
getDomainLabel_ :: !BS.ShortByteString
                               , DomainLabel -> 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 (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
Ord)

instance Ord DomainLabel where
  <= :: DomainLabel -> DomainLabel -> Bool
(<=) = ShortByteString -> ShortByteString -> Bool
forall a. Ord a => a -> a -> Bool
(<=) (ShortByteString -> ShortByteString -> Bool)
-> (DomainLabel -> ShortByteString)
-> DomainLabel
-> DomainLabel
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DomainLabel -> ShortByteString
getDomainLabelCF_
  compare :: DomainLabel -> DomainLabel -> Ordering
compare = ShortByteString -> ShortByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ShortByteString -> ShortByteString -> Ordering)
-> (DomainLabel -> ShortByteString)
-> DomainLabel
-> DomainLabel
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DomainLabel -> ShortByteString
getDomainLabelCF_

instance Eq DomainLabel where
  == :: DomainLabel -> DomainLabel -> Bool
(==) = ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ShortByteString -> ShortByteString -> Bool)
-> (DomainLabel -> ShortByteString)
-> DomainLabel
-> DomainLabel
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DomainLabel -> ShortByteString
getDomainLabelCF_

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

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

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

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

instance Semigroup (DList a) where
  {-# INLINE (<>) #-}
  DList [a] -> [a]
l <> :: DList a -> DList a -> DList a
<> DList [a] -> [a]
r = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
DList ([a] -> [a]
l ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
r)

instance Monoid (DList a) where
  {-# INLINE mempty #-}
  mempty :: DList a
mempty = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
DList [a] -> [a]
forall a. a -> a
id

-- | 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 = [Char] -> DList Char
forall a. [a] -> DList a
toDList ([Word8] -> [Char]
replace (ShortByteString -> [Word8]
BS.unpack ShortByteString
bs))
  where
    {-# INLINE replace #-}
    replace :: [Word8] -> [Char]
    replace :: [Word8] -> [Char]
replace (Word8
x:[Word8]
xs) = case Word8
x of
      Word8
_ | Char -> Bool
isLabelChar (Word8 -> Char
w2c Word8
x)
           -> (Word8 -> Char
w2c Word8
x) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs

      Word8
0x2e -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'.' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
      Word8
0x5c -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
replace [Word8]
xs
      Word8
_    -> Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o2 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
o3 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
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)

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