-- |
-- Module      : Net.DNSBase.Internal.Domain
-- Description : TBD
-- Copyright   : (c) Viktor Dukhovni, 2026
-- License     : BSD-3-Clause
-- Maintainer  : ietf-dane@dukhovni.org
-- Stability   : unstable
{-# LANGUAGE
    DeriveLift
  , DerivingStrategies
  , RecordWildCards
  , TemplateHaskell
  #-}

module Net.DNSBase.Internal.Domain
    ( -- ** Domain name data type
      Domain(.., RootDomain)
    , DnsTriple(..)
    , Host
    , fromHost
    , toHost
    , Mbox
    , fromMbox
    , toMbox
    -- *** Canonicalisation to lower case
    , canonicalise
    -- *** Working with labels
    , appendDomain
    , consDomain
    , unconsDomain
    , fromLabels
    , labelCount
    , toLabels
    , revLabels
    , commonSuffix
    -- ** Validating import from wire form
    , wireToDomain
    -- ** Decode presentation form to Domain
    , decodePresentationDomain
    , decodePresentationMbox
    -- ** Compile-time literals
    , dnLit
    , mbLit
    -- ** Binary serialization functions
    , wireBytes
    , mbWireForm
    , buildDomain
    -- ** Predicates
    , isLDHLabel
    , isLDHName
    -- ** Sorting and comparison
    , compareWireHost
    , equalWireHost
    , canonicalNameOrder
    , sortDomains
    ) where

import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Short as SB
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Unsafe as B
import qualified Data.List as L
import qualified Data.Primitive.ByteArray as A
import qualified Data.Text as T
import qualified Data.Text.Array as TA
import qualified Data.Text.Internal as TI
import qualified Data.Text.Unsafe as T
import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad.ST (ST, runST)
import Data.Bifunctor (first)
import Data.Foldable (foldlM)

import Net.DNSBase.Encode.Internal.Metric
import Net.DNSBase.Internal.Present
import Net.DNSBase.Internal.RRCLASS
import Net.DNSBase.Internal.RRTYPE
import Net.DNSBase.Internal.Text
import Net.DNSBase.Internal.Util

---------------------------------------- Domain newtype

-- | This type holds the /wire form/ of fully-qualified DNS domain
-- names encoded as A-labels.
--
-- The encoding of valid domain names to /presentation form/ (the
-- 'Presentable' instance) performs any required escaping of
-- special characters to ensure lossless round-trip encoding and
-- decoding of valid DNS names, and compatibility with the
-- standard zone file format.  Valid names are not limited to the
-- letter-digit-hyphen (LDH) syntax of hostnames, all 8-bit
-- characters are allowed in DNS names, subject to the 63-byte
-- limit on /wire form/ label length and 255-byte limit on the
-- /wire form/ domain name (including the terminal empty label).
--
-- Equality and comparison are based on the wire-form and are
-- case-sensitive.  The 'Host' newtype implements case-insensitive
-- equality and comparison over the same wire-form bytes.  The
-- 'toHost' and 'fromHost' functions implement coercions between
-- the two types.
--
newtype Domain = Domain_
    {
    -- | The /wire form/ of a domain name, including the zero-valued
    -- length byte of the terminal empty label.
    Domain -> ShortByteString
shortBytes :: ShortByteString
    } deriving stock (forall (m :: * -> *). Quote m => Domain -> m Exp)
-> (forall (m :: * -> *). Quote m => Domain -> Code m Domain)
-> Lift Domain
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Domain -> m Exp
forall (m :: * -> *). Quote m => Domain -> Code m Domain
$clift :: forall (m :: * -> *). Quote m => Domain -> m Exp
lift :: forall (m :: * -> *). Quote m => Domain -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Domain -> Code m Domain
liftTyped :: forall (m :: * -> *). Quote m => Domain -> Code m Domain
TH.Lift
      deriving newtype (Domain -> Domain -> Bool
(Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool) -> Eq Domain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Domain -> Domain -> Bool
== :: Domain -> Domain -> Bool
$c/= :: Domain -> Domain -> Bool
/= :: 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
$ccompare :: Domain -> Domain -> Ordering
compare :: Domain -> Domain -> Ordering
$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
>= :: Domain -> Domain -> Bool
$cmax :: Domain -> Domain -> Domain
max :: Domain -> Domain -> Domain
$cmin :: Domain -> Domain -> Domain
min :: Domain -> Domain -> Domain
Ord)


-- | Coercible to/from a domain, but its presentation form is canonical (lower
-- case) and has no terminating @.@, unless this is the root domain.
--
-- Equality and order are on the wire form, but are case-insensitive.
newtype Host = Host ShortByteString

-- | Case-insensitive equality on the wire form.
instance Eq Host where
    Host
a == :: Host -> Host -> Bool
== Host
b = Host -> Domain
fromHost Host
a Domain -> Domain -> Bool
`equalWireHost` Host -> Domain
fromHost Host
b

-- | Case-insensitive order on the wire form.
instance Ord Host where
    Host
a compare :: Host -> Host -> Ordering
`compare` Host
b = Host -> Domain
fromHost Host
a Domain -> Domain -> Ordering
`compareWireHost` Host -> Domain
fromHost Host
b

-- | Coerce a 'Domain' to a 'Host'.
toHost :: Domain -> Host;   toHost :: Domain -> Host
toHost = Domain -> Host
forall a b. Coercible a b => a -> b
coerce
-- | Coerce a 'Host' to a 'Domain'.
fromHost :: Host -> Domain; fromHost :: Host -> Domain
fromHost = Host -> Domain
forall a b. Coercible a b => a -> b
coerce


-- | Coercible to\/from a domain, but its presentation form uses the @\@@ sign
-- as the separator after the first label, and does not escape literal @.@
-- characters within the first label. The second and subsequent labels are
-- canonicalised to lower-case.  No terminating @.@ is appended unless this
-- is the root domain.
--
-- Equality and order are on the wire form, but are case-insensitive.
newtype Mbox = Mbox ShortByteString deriving (Mbox -> Mbox -> Bool
(Mbox -> Mbox -> Bool) -> (Mbox -> Mbox -> Bool) -> Eq Mbox
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mbox -> Mbox -> Bool
== :: Mbox -> Mbox -> Bool
$c/= :: Mbox -> Mbox -> Bool
/= :: Mbox -> Mbox -> Bool
Eq, Eq Mbox
Eq Mbox =>
(Mbox -> Mbox -> Ordering)
-> (Mbox -> Mbox -> Bool)
-> (Mbox -> Mbox -> Bool)
-> (Mbox -> Mbox -> Bool)
-> (Mbox -> Mbox -> Bool)
-> (Mbox -> Mbox -> Mbox)
-> (Mbox -> Mbox -> Mbox)
-> Ord Mbox
Mbox -> Mbox -> Bool
Mbox -> Mbox -> Ordering
Mbox -> Mbox -> Mbox
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
$ccompare :: Mbox -> Mbox -> Ordering
compare :: Mbox -> Mbox -> Ordering
$c< :: Mbox -> Mbox -> Bool
< :: Mbox -> Mbox -> Bool
$c<= :: Mbox -> Mbox -> Bool
<= :: Mbox -> Mbox -> Bool
$c> :: Mbox -> Mbox -> Bool
> :: Mbox -> Mbox -> Bool
$c>= :: Mbox -> Mbox -> Bool
>= :: Mbox -> Mbox -> Bool
$cmax :: Mbox -> Mbox -> Mbox
max :: Mbox -> Mbox -> Mbox
$cmin :: Mbox -> Mbox -> Mbox
min :: Mbox -> Mbox -> Mbox
Ord) via Host

-- | Coerce a 'Domain' to an 'Mbox'.  This changes the presentation form
-- to one in which the first label is separated from the rest by an @\'\@\'@
-- character, and any dots in the first label remain unescaped. No period
-- is appended after the last label.  The same form can be parsed by:
--
-- * 'Net.DNSBase.Domain.mbLit8'
-- * 'Net.DNSBase.Domain.makeMbox8'
-- * 'Net.DNSBase.Domain.makeMbox8Str'
-- * 'mbLit'
-- * 'decodePresentationMbox'
--
-- provided the first label (localpart) uses only 7-bit ASCII characters.
-- Mailboxes with non-ASCII localparts (EAI addresses) must be valid UTF-8
-- and can only be parsed by 'decodePresentationMbox' or 'mbLit', but
-- the presentation form of 'Mbox' does escapes all non-ASCII bytes in
-- @\\DDD@ decimal form, and would be rejected by all the above parsers.
-- A UTF-8 presentation form that respects EAI addresses is not yet
-- available, and would probably want a new @EAIMbox@ data type.
--
toMbox :: Domain -> Mbox;   toMbox :: Domain -> Mbox
toMbox = Domain -> Mbox
forall a b. Coercible a b => a -> b
coerce
-- | Coerce an 'Mbox' to a 'Domain'.
fromMbox :: Mbox -> Domain; fromMbox :: Mbox -> Domain
fromMbox = Mbox -> Domain
forall a b. Coercible a b => a -> b
coerce


-- | An /RRSet/ is uniquely idenfified by a name, type, class triple.
data DnsTriple = DnsTriple {
    DnsTriple -> Domain
dnsTripleName  :: Domain
  , DnsTriple -> RRTYPE
dnsTripleType  :: RRTYPE
  , DnsTriple -> RRCLASS
dnsTripleClass :: RRCLASS
  } deriving (DnsTriple -> DnsTriple -> Bool
(DnsTriple -> DnsTriple -> Bool)
-> (DnsTriple -> DnsTriple -> Bool) -> Eq DnsTriple
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DnsTriple -> DnsTriple -> Bool
== :: DnsTriple -> DnsTriple -> Bool
$c/= :: DnsTriple -> DnsTriple -> Bool
/= :: DnsTriple -> DnsTriple -> Bool
Eq, Int -> DnsTriple -> ShowS
[DnsTriple] -> ShowS
DnsTriple -> String
(Int -> DnsTriple -> ShowS)
-> (DnsTriple -> String)
-> ([DnsTriple] -> ShowS)
-> Show DnsTriple
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DnsTriple -> ShowS
showsPrec :: Int -> DnsTriple -> ShowS
$cshow :: DnsTriple -> String
show :: DnsTriple -> String
$cshowList :: [DnsTriple] -> ShowS
showList :: [DnsTriple] -> ShowS
Show)

instance Presentable DnsTriple where
    present :: DnsTriple -> Builder -> Builder
present DnsTriple {RRTYPE
RRCLASS
Domain
dnsTripleName :: DnsTriple -> Domain
dnsTripleType :: DnsTriple -> RRTYPE
dnsTripleClass :: DnsTriple -> RRCLASS
dnsTripleName :: Domain
dnsTripleType :: RRTYPE
dnsTripleClass :: RRCLASS
..} =
        Domain -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Domain
dnsTripleName
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRCLASS -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp RRCLASS
dnsTripleClass
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRTYPE -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp RRTYPE
dnsTripleType


-- | The internal representation of Domains is not exposed, so neither the the
-- wire form nor any labels except the last can be empty.  The total length
-- cannot exceed 255 and no label can be longer than 63 bytes.
impossible :: a
impossible :: forall a. a
impossible = String -> a
forall a. HasCallStack => String -> a
error String
"Impossible wire format domain"

rootDomain :: Domain
rootDomain :: Domain
rootDomain = ShortByteString -> Domain
forall a b. Coercible a b => a -> b
coerce (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$ Word8 -> ShortByteString
SB.singleton Word8
0

-- | The root 'Domain' (presentation form @.@).
pattern RootDomain :: Domain
pattern $mRootDomain :: forall {r}. Domain -> ((# #) -> r) -> ((# #) -> r) -> r
$bRootDomain :: Domain
RootDomain <- Domain_ (SB.length -> 1) where
    RootDomain = Domain
rootDomain

-- | Return the wire form of a 'Domain' name as a 'ByteString'
wireBytes :: Domain -> ByteString
wireBytes :: Domain -> ByteString
wireBytes = ShortByteString -> ByteString
SB.fromShort (ShortByteString -> ByteString)
-> (Domain -> ShortByteString) -> Domain -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ShortByteString
shortBytes

-- | Case-insensitive equality of domain names.
equalWireHost :: Domain -> Domain -> Bool
equalWireHost :: Domain -> Domain -> Bool
equalWireHost (Domain_ ShortByteString
sa) (Domain_ ShortByteString
sb)
    | Int
lena Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
lenb                                 = Bool
False
    | ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering
A.compareByteArrays ByteArray
arra Int
0 ByteArray
arrb Int
0 Int
lena Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ = Bool
True
    | Bool
otherwise                                    = Int -> Bool
go Int
0
  where
    lena :: Int
lena = ShortByteString -> Int
SB.length ShortByteString
sa
    lenb :: Int
lenb = ShortByteString -> Int
SB.length ShortByteString
sb
    arra :: ByteArray
arra = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sa
    arrb :: ByteArray
arrb = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sb

    go :: Int -> Bool
go !Int
off
        | Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lena = Bool
True
        | Word8 -> Word8
tolower Word8
wa Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8 -> Word8
tolower Word8
wb = Bool
False
        | Bool
otherwise = Int -> Bool
go (Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      where
        wa :: Word8
wa = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arra Int
off
        wb :: Word8
wb = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arrb Int
off

-- | Canonical name order:
-- <https://datatracker.ietf.org/doc/html/rfc4034#section-6.1>.  For sorting
-- lists of more than a few elements, it may be best to perform a /decorate/,
-- sort, /undecorate/ via 'sortDomains'.
--
canonicalNameOrder :: Domain -> Domain -> Ordering
canonicalNameOrder :: Domain -> Domain -> Ordering
canonicalNameOrder Domain
a Domain
b
    | Domain
a Domain -> Domain -> Bool
`equalWireHost` Domain
b = Ordering
EQ
    | Bool
otherwise = [ByteString] -> [ByteString] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Domain -> [ByteString]
revLabels (Domain -> [ByteString]) -> Domain -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Domain -> Domain
canonicalise Domain
a)
                          (Domain -> [ByteString]
revLabels (Domain -> [ByteString]) -> Domain -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Domain -> Domain
canonicalise Domain
b)

-- | Case-insensitive comparison of the wire forms of domains.
compareWireHost :: Domain -> Domain -> Ordering
compareWireHost :: Domain -> Domain -> Ordering
compareWireHost (Domain_ ShortByteString
sa) (Domain_ ShortByteString
sb) = Int -> Ordering
go Int
0
  where
    lena :: Int
lena = ShortByteString -> Int
SB.length ShortByteString
sa
    lenb :: Int
lenb = ShortByteString -> Int
SB.length ShortByteString
sb
    arra :: ByteArray
arra = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sa
    arrb :: ByteArray
arrb = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sb

    go :: Int -> Ordering
go !Int
off
        | Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lena = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lena Int
lenb
        | Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lenb = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lena Int
lenb
        | Ordering
cmp Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ       = Ordering
cmp
        | Bool
otherwise       = Int -> Ordering
go (Int -> Ordering) -> Int -> Ordering
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      where
        wa :: Word8
wa = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arra Int
off
        wb :: Word8
wb = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arrb Int
off
        cmp :: Ordering
cmp = Word8 -> Word8 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word8 -> Word8
tolower Word8
wa) (Word8 -> Word8
tolower Word8
wb)

-- | Perform a /decorate/, sort, /undecorate/ sort to return a list of domains
-- in canonical order.
sortDomains :: [Domain] -> [Domain]
sortDomains :: [Domain] -> [Domain]
sortDomains = (Domain -> [ByteString]) -> [Domain] -> [Domain]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Domain -> [ByteString]
revLabels (Domain -> [ByteString])
-> (Domain -> Domain) -> Domain -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Domain
canonicalise)

-- | Conversion to /presentation form/ via a bytestring 'Builder'.
instance Presentable Domain where
    present :: Domain -> Builder -> Builder
present = Domain -> Builder -> Builder
presentDomain
    -- | Executes the 'Domain' builder with sensibly short buffers.
    presentLazy :: Domain -> LazyByteString -> LazyByteString
presentLazy Domain
d LazyByteString
k = AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
B.toLazyByteStringWith AllocationStrategy
domainStrat LazyByteString
k (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Domain -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Domain
d Builder
forall a. Monoid a => a
mempty

-- | Conversion to /presentation form/ via a bytestring 'Builder'.
instance Presentable Host where
    present :: Host -> Builder -> Builder
present = Domain -> Builder -> Builder
presentHost (Domain -> Builder -> Builder)
-> (Host -> Domain) -> Host -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Domain
forall a b. Coercible a b => a -> b
coerce
    -- | Executes the 'Host' builder with sensibly short buffers.
    presentLazy :: Host -> LazyByteString -> LazyByteString
presentLazy Host
h LazyByteString
k = AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
B.toLazyByteStringWith AllocationStrategy
domainStrat LazyByteString
k (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Host -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Host
h Builder
forall a. Monoid a => a
mempty

-- | Conversion to /presentation form/ via a bytestring 'Builder'.
instance Presentable Mbox where
    present :: Mbox -> Builder -> Builder
present = Domain -> Builder -> Builder
presentMbox (Domain -> Builder -> Builder)
-> (Mbox -> Domain) -> Mbox -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mbox -> Domain
forall a b. Coercible a b => a -> b
coerce
    -- | Executes the 'Mbox' builder with sensibly short buffers.
    presentLazy :: Mbox -> LazyByteString -> LazyByteString
presentLazy Mbox
m LazyByteString
k = AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
B.toLazyByteStringWith AllocationStrategy
domainStrat LazyByteString
k (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Mbox -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Mbox
m Builder
forall a. Monoid a => a
mempty

-- | Shows the presentation form string, adding double quotes and additional
-- string escapes as needed.  To get the /raw/ string, use 'presentString'.
instance Show Domain where
    showsPrec :: Int -> Domain -> ShowS
showsPrec Int
p Domain
d = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Domain -> ShowS
forall a. Presentable a => a -> ShowS
presentString Domain
d String
forall a. Monoid a => a
mempty

-- | Shows the presentation form string, adding double quotes and additional
-- string escapes as needed.  To get the /raw/ string, use 'presentString'.
instance Show Host where
    showsPrec :: Int -> Host -> ShowS
showsPrec Int
p Host
h = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Host -> ShowS
forall a. Presentable a => a -> ShowS
presentString Host
h String
forall a. Monoid a => a
mempty

-- | Shows the presentation form string, adding double quotes and additional
-- string escapes as needed.  To get the /raw/ string, use 'presentString'.
instance Show Mbox where
    showsPrec :: Int -> Mbox -> ShowS
showsPrec Int
p Mbox
m = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Mbox -> ShowS
forall a. Presentable a => a -> ShowS
presentString Mbox
m String
forall a. Monoid a => a
mempty

---------------------------------------- Wire-form assembly

-- | Execute a builder to produce a 'Domain'.  Used by the wire-form
-- decoder to turn the @\<prefix\>\<suffix\>@ Builder produced by
-- pointer-following into a 'Domain'; the presentation-form parsers
-- live in "Net.DNSBase.Domain" and write directly into a fresh
-- 'A.MutableByteArray' rather than going via Builder.
buildDomain :: Maybe B.Builder -> Maybe Domain
buildDomain :: Maybe Builder -> Maybe Domain
buildDomain Maybe Builder
mb = Maybe Builder
mb Maybe Builder -> (Builder -> Maybe Domain) -> Maybe Domain
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Builder
b -> do
    let buf :: ByteString
buf = LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
B.toLazyByteStringWith AllocationStrategy
domainStrat LazyByteString
forall a. Monoid a => a
mempty Builder
b
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
buf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256
    Domain -> Maybe Domain
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Domain -> Maybe Domain) -> Domain -> Maybe Domain
forall a b. (a -> b) -> a -> b
$! ShortByteString -> Domain
Domain_ (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$ ByteString -> ShortByteString
SB.toShort ByteString
buf

---------------------------------------- Conversions


-- | Given two 'Domain's attempt to construct a new new domain consisting
-- of the labels of the first, followed by the labels of the second.  Fails
-- (returns 'Nothing') if the result would be too long.
--
appendDomain :: Domain -> Domain -> Maybe Domain
appendDomain :: Domain -> Domain -> Maybe Domain
appendDomain p :: Domain
p@(Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> (Domain -> Int) -> Domain -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortByteString -> Int) -> Domain -> Int
forall a b. Coercible a b => a -> b
coerce ShortByteString -> Int
SB.length -> Int
plen)
             s :: Domain
s@((ShortByteString -> Int) -> Domain -> Int
forall a b. Coercible a b => a -> b
coerce ShortByteString -> Int
SB.length -> Int
slen)
    | Int
plen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
s
    | Int
slen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
p
    | Int
len <- Int
plen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slen
    , Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = Domain -> Maybe Domain
forall a. a -> Maybe a
Just (Domain -> Maybe Domain) -> Domain -> Maybe Domain
forall a b. (a -> b) -> a -> b
$! ShortByteString -> Domain
Domain_ (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$ Int -> ShortByteString
combine Int
len
    | Bool
otherwise = Maybe Domain
forall a. Maybe a
Nothing
  where
    combine :: Int -> ShortByteString
combine Int
len = ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutableByteArray s)) -> ByteArray
A.runByteArray do
        mba <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
A.newByteArray Int
len
        A.copyByteArray mba 0 (sbsToByteArray $ shortBytes p) 0 plen
        A.copyByteArray mba plen (sbsToByteArray $ shortBytes s) 0 slen
        pure mba


-- | Canonicalise a 'Domain' to lower-case form.
canonicalise :: Domain -> Domain
canonicalise :: Domain -> Domain
canonicalise domain :: Domain
domain@(Domain -> ShortByteString
shortBytes -> ShortByteString
bytes)
    | (Word8 -> Bool) -> ShortByteString -> Bool
SB.any Word8 -> Bool
isupper ShortByteString
bytes = ShortByteString -> Domain
Domain_ (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8) -> ShortByteString -> ShortByteString
SB.map Word8 -> Word8
tolower ShortByteString
bytes
    | Bool
otherwise = Domain
domain


-- | Attempt to prepend the given label to the given domain, provided the label
-- length is 63 bytes or less, and the resulting domain is not too long.
--
consDomain :: ShortByteString -> Domain -> Maybe Domain
consDomain :: ShortByteString -> Domain -> Maybe Domain
consDomain label :: ShortByteString
label@(ShortByteString -> Int
SB.length -> Int
llen)  suffix :: Domain
suffix@((ShortByteString -> Int) -> Domain -> Int
forall a b. Coercible a b => a -> b
coerce ShortByteString -> Int
SB.length -> Int
slen) = do
    let len :: Int
len = Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slen
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
llen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
llen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256
    Domain -> Maybe Domain
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Domain -> Maybe Domain) -> Domain -> Maybe Domain
forall a b. (a -> b) -> a -> b
$! ShortByteString -> Domain
Domain_ (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$ Int -> ShortByteString
combine Int
len
  where
    combine :: Int -> ShortByteString
combine Int
len = ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutableByteArray s)) -> ByteArray
A.runByteArray do
        mba <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
A.newByteArray Int
len
        A.writeByteArray mba 0 (i2w llen)
        A.copyByteArray mba 1 (sbsToByteArray label) 0 llen
        A.copyByteArray mba (llen+1) (sbsToByteArray $ shortBytes suffix) 0 slen
        pure mba


-- | Given a 'Domain', return a tuple containing its first unescaped label as a
-- 'ShortByteString' and the remainder of the 'Domain' after removing the first
-- label.  Returns 'Nothing' for the root domain.
--
unconsDomain :: Domain -> Maybe (ShortByteString, Domain)
unconsDomain :: Domain -> Maybe (ShortByteString, Domain)
unconsDomain (Domain_ ShortByteString
sbs)
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1   = (ShortByteString, Domain) -> Maybe (ShortByteString, Domain)
forall a. a -> Maybe a
Just (ShortByteString
label, ShortByteString -> Domain
Domain_ ShortByteString
suffix)
    | Bool
otherwise = Maybe (ShortByteString, Domain)
forall a. Maybe a
Nothing
  where
    len :: Int
len     = ShortByteString -> Int
SB.length ShortByteString
sbs
    ba :: ByteArray
ba      = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sbs
    llen :: Int
llen    = Word8 -> Int
w2i (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
ba Int
0
    slen :: Int
slen    = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    !label :: ShortByteString
label  = ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Int -> ByteArray
A.cloneByteArray ByteArray
ba Int
1 Int
llen
    !suffix :: ShortByteString
suffix = ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Int -> ByteArray
A.cloneByteArray ByteArray
ba (Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
slen


-- | Given a constituent list of raw unescaped labels, construct the
-- corresponding /wire form/ domain name. No label may be empty or longer than
-- 63 bytes, and the number of labels + the sum of label lengths must not
-- exceed 254.  The return value is 'Nothing' if the length constraints are
-- violated.
--
-- prop> fromLabels (toLabels dn) == Just dn
fromLabels :: [ShortByteString] -> Maybe Domain
fromLabels :: [ShortByteString] -> Maybe Domain
fromLabels [ShortByteString]
ls = do
    len <- (Int -> ShortByteString -> Maybe Int)
-> Int -> [ShortByteString] -> Maybe Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Int -> ShortByteString -> Maybe Int
space Int
1 [ShortByteString]
ls
    pure $! Domain_ $ combine len
  where
    space :: Int -> ShortByteString -> Maybe Int
    space :: Int -> ShortByteString -> Maybe Int
space Int
acc (ShortByteString -> Int
SB.length -> Int
len)
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64
        , Int
new <- Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        , Int
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
new
        | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

    combine :: Int -> ShortByteString
combine Int
len = ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutableByteArray s)) -> ByteArray
A.runByteArray do
        mba <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
A.newByteArray Int
len
        go mba 0 ls

    go :: MutableByteArray (PrimState m)
-> Int -> [ShortByteString] -> m (MutableByteArray (PrimState m))
go MutableByteArray (PrimState m)
mba Int
off (ShortByteString
l : [ShortByteString]
rest) = do
        let !llen :: Int
llen = ShortByteString -> Int
SB.length ShortByteString
l
        MutableByteArray (PrimState m) -> Int -> Word8 -> m ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray MutableByteArray (PrimState m)
mba Int
off (Word8 -> m ()) -> Word8 -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8
i2w Int
llen
        MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
A.copyByteArray MutableByteArray (PrimState m)
mba (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (ShortByteString -> ByteArray
sbsToByteArray ShortByteString
l) Int
0 Int
llen
        MutableByteArray (PrimState m)
-> Int -> [ShortByteString] -> m (MutableByteArray (PrimState m))
go MutableByteArray (PrimState m)
mba (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ShortByteString]
rest
    go MutableByteArray (PrimState m)
mba Int
off [ShortByteString]
_ = MutableByteArray (PrimState m)
mba MutableByteArray (PrimState m)
-> m () -> m (MutableByteArray (PrimState m))
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray @Word8 MutableByteArray (PrimState m)
mba Int
off Word8
0


-- | Validating import of a wire-form 'ShortByteString' as a
-- 'Domain'.  Returns 'Just' iff the bytes are a well-formed DNS
-- domain on the wire:
--
--   * total length in @1..255@,
--   * every label length byte in @1..63@ except the trailing
--     zero-byte root label,
--   * label boundaries align exactly with the buffer end -- i.e.
--     the terminating empty label's NUL length-byte is the last
--     byte, and there is no truncation or trailing garbage.
--
-- Suitable for receiving bytes the caller cannot prove
-- well-formed (e.g. labels handed back by a foreign library or
-- another package).  Wire-form bytes that come straight from the
-- decoder in "Net.DNSBase.Decode.Domain" are already validated and
-- do not need to round-trip through this check.
wireToDomain :: ShortByteString -> Maybe Domain
wireToDomain :: ShortByteString -> Maybe Domain
wireToDomain ShortByteString
sbs
    | Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1, Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255, Int -> Bool
walk Int
0 = Domain -> Maybe Domain
forall a. a -> Maybe a
Just (ShortByteString -> Domain
Domain_ ShortByteString
sbs)
    | Bool
otherwise                        = Maybe Domain
forall a. Maybe a
Nothing
  where
    !arr :: ByteArray
arr   = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sbs
    !total :: Int
total = ShortByteString -> Int
SB.length ShortByteString
sbs

    walk :: Int -> Bool
    walk :: Int -> Bool
walk !Int
off
        | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
total = Bool
False    -- ran off end without hitting root NUL
        | Bool
otherwise =
            let !lb :: Int
lb = Word8 -> Int
w2i (ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arr Int
off :: Word8)
            in if Int
lb Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total              -- root NUL is the last byte
                 else Int
lb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63 Bool -> Bool -> Bool
&& Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
total
                                Bool -> Bool -> Bool
&& Int -> Bool
walk (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lb)


-- | Template-Haskell typed splice for a compile-time 'Domain'
-- literal.  The caller supplies a parser of type
-- @'Text' -> 'Either' e 'ShortByteString'@; @dnLit@ packs the
-- source 'String' literal as 'Text', runs the parser at compile
-- time, additionally checks the bytes via 'wireToDomain', and
-- embeds the resulting 'Domain' as a constant.  An invalid literal
-- (parser failure /or/ wire-shape failure) becomes a compile-time
-- error.
--
-- The @dnsbase@ library deliberately does not bundle a domain
-- parser; users compose a parser of their choice and pass it in.
-- The natural source of validating parsers is the @idna2008@
-- package, whose parsers already operate on 'Text'.
-- Template-Haskell staging forbids referring to a same-module
-- top-level binding from inside the splice, so the parser must
-- either be defined in an /imported/ module or bound by a @let@
-- /inside/ the splice; for a single-call site the latter is the
-- more compact form:
--
-- > import qualified Text.IDNA2008 as I
-- >
-- > example :: Domain
-- > example = $$(let parser = fmap I.wireBytesShort . I.mkDomain
-- >               in dnLit parser "www.example.org")
--
-- @mkDomain@ runs strict IDNA2008 with default label forms and
-- no mappings, returning just the validated @idna2008@ library\'s
-- 'Domain' object.  The @I.wireBytesShort@ function extracts the
-- wire form bytes needed by 'dnLit'.
--
-- For looser policies (mappings, emoji domain tolerance, etc.) use
-- @parseDomainOpt@ with an explicit @LabelFormSet@ and @IDNAOpts@,
-- and discard the @LabelInfo@ half of its result.
--
-- Hoisting the parser into a separate module avoids retyping the
-- composition at every literal:
--
-- > -- in MyDomainParsers.hs
-- > strictParser :: Text -> Either I.IdnaError ShortByteString
-- > strictParser = fmap I.wireBytesShort . I.mkDomain
-- >
-- > -- in any module that imports MyDomainParsers
-- > example :: Domain
-- > example = $$(dnLit strictParser "www.example.org")
--
-- The source literal is converted to 'Text' before the parser is
-- invoked; literals whose UTF-8 byte length exceeds 1024 are
-- rejected as invalid without consulting the parser.  The emitted
-- splice is a constant 'Domain' value (the wire-form
-- 'ShortByteString' is materialised once from its compile-time
-- @Addr#@ literal on first evaluation); the splice itself runs no
-- runtime IDNA code, and the caller's binary carries no
-- @idna2008@ dependency unless the user imports it themselves.
--
dnLit :: forall e m. (Show e, MonadFail m, TH.Quote m)
      => (Text -> Either e ShortByteString) -- ^ Parser
      -> String -- ^ Input literal (source code shape)
      -> TH.Code m Domain
dnLit :: forall e (m :: * -> *).
(Show e, MonadFail m, Quote m) =>
(Text -> Either e ShortByteString) -> String -> Code m Domain
dnLit Text -> Either e ShortByteString
parse String
s = m (Code m Domain) -> Code m Domain
forall (m :: * -> *) a. Monad m => m (Code m a) -> Code m a
TH.joinCode case Int -> String -> Maybe Text
packBounded Int
mboxPresentationMaxBytes String
s of
    Maybe Text
Nothing -> String -> m (Code m Domain)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Code m Domain)) -> String -> m (Code m Domain)
forall a b. (a -> b) -> a -> b
$ String
"Invalid literal domain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": presentation form longer than "
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mboxPresentationMaxBytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes"
    Just Text
t  -> case Text -> Either e ShortByteString
parse Text
t of
        Left e
why -> String -> m (Code m Domain)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Code m Domain)) -> String -> m (Code m Domain)
forall a b. (a -> b) -> a -> b
$ String
"Invalid literal domain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
why
        Right ShortByteString
bs -> case ShortByteString -> Maybe Domain
wireToDomain ShortByteString
bs of
            Just Domain
dn -> Code m Domain -> m (Code m Domain)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Domain -> Code m Domain
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => Domain -> Code m Domain
TH.liftTyped Domain
dn)
            Maybe Domain
Nothing -> String -> m (Code m Domain)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Code m Domain)) -> String -> m (Code m Domain)
forall a b. (a -> b) -> a -> b
$ String
"Invalid domain: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s

----------------------------------------------------------------------
-- Decode a presentation-form domain
----------------------------------------------------------------------

-- | Decode a domain in presentation form.  The caller supplies the
-- parser; this entry point validates the parser's output as a
-- wire-form 'ShortByteString' that 'wireToDomain' accepts.
--
-- When the parser returns an error @e@, the return value is
-- @Left (Just e)@.  If a buggy parser produces an invalid wire
-- form, the return value is @Left Nothing@.
decodePresentationDomain
    :: forall e
    .  (Text -> Either e ShortByteString) -- ^ Parser
    -> Text                               -- ^ Input to be parsed
    -> Either (Maybe e) Domain
decodePresentationDomain :: forall e.
(Text -> Either e ShortByteString)
-> Text -> Either (Maybe e) Domain
decodePresentationDomain Text -> Either e ShortByteString
parser Text
t = case Text -> Either e ShortByteString
parser Text
t of
    Right ShortByteString
bs -> Either (Maybe e) Domain
-> (Domain -> Either (Maybe e) Domain)
-> Maybe Domain
-> Either (Maybe e) Domain
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe e -> Either (Maybe e) Domain
forall a b. a -> Either a b
Left Maybe e
forall a. Maybe a
Nothing) Domain -> Either (Maybe e) Domain
forall a b. b -> Either a b
Right (Maybe Domain -> Either (Maybe e) Domain)
-> Maybe Domain -> Either (Maybe e) Domain
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Maybe Domain
wireToDomain ShortByteString
bs
    Left e
why -> Maybe e -> Either (Maybe e) Domain
forall a b. a -> Either a b
Left (Maybe e -> Either (Maybe e) Domain)
-> Maybe e -> Either (Maybe e) Domain
forall a b. (a -> b) -> a -> b
$ e -> Maybe e
forall a. a -> Maybe a
Just e
why

----------------------------------------------------------------------
-- Decode a presentation-form mbox
----------------------------------------------------------------------

-- | Parse a presentation-form mailbox into a 'Domain'.
--
-- The input is split at the first unescaped @\'\@\'@ if any;
-- otherwise at the first unescaped @\'.\'@; otherwise the entire
-- input is the localpart and the resulting 'Domain' has a single
-- non-root label.  A separator present but followed by empty
-- domain text (e.g. @\"postmaster\@\"@ or @\"postmaster.\"@) is
-- treated the same way as if the separator were absent: the
-- localpart is one label, the domain part is the root domain.
--
-- Following EAI semantics (RFC 6532), the localpart's wire bytes
-- are either pure 7-bit ASCII or a well-formed UTF-8 sequence.
-- The localpart decoder:
--
--   * Copies unescaped 'Text' bytes verbatim into the wire form.
--     A 'Text' is already valid UTF-8, so the bytes for one
--     codepoint are 1, 2, 3 or 4 bytes long depending on the
--     codepoint; no decoding or validation is needed.
--   * @\\DDD@ (three ASCII decimal digits, @0..127@) emits the
--     single ASCII byte with that value.  Values @>= 128@ are
--     rejected.
--   * @\\X@ (any other single character) emits @X@ as a single
--     ASCII byte; @X@'s codepoint must be @< 0x80@.
--
-- The rules above apply only to the /localpart/ -- the first
-- label of the mailbox name.  The post-separator 'Text' (if any)
-- is handed verbatim to the caller-supplied domain parser, which
-- decodes any remaining labels.
--
-- The parser's output is validated to be a wire-form
-- 'ShortByteString' that 'wireToDomain' accepts.  If length
-- limits permit, the decoded localpart is prepended to form the
-- combined 'Domain'.
--
-- When the parser returns an error @e@, the return value is
-- @Left (Just e)@.  If a buggy parser produces an invalid wire
-- form, the return value is @Left Nothing@.
decodePresentationMbox
    :: forall e
    .  (Text -> Either e ShortByteString) -- ^ Parser
    -> Text                               -- ^ Input to be parsed
    -> Either (Maybe e) Domain
decodePresentationMbox :: forall e.
(Text -> Either e ShortByteString)
-> Text -> Either (Maybe e) Domain
decodePresentationMbox Text -> Either e ShortByteString
parseDom Text
t = do
    (lpBytes, rest) <- Either (Maybe e) (ShortByteString, Text)
-> ((ShortByteString, Text)
    -> Either (Maybe e) (ShortByteString, Text))
-> Maybe (ShortByteString, Text)
-> Either (Maybe e) (ShortByteString, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe e -> Either (Maybe e) (ShortByteString, Text)
forall a b. a -> Either a b
Left Maybe e
forall a. Maybe a
Nothing) (ShortByteString, Text) -> Either (Maybe e) (ShortByteString, Text)
forall a. a -> Either (Maybe e) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ShortByteString, Text)
 -> Either (Maybe e) (ShortByteString, Text))
-> Maybe (ShortByteString, Text)
-> Either (Maybe e) (ShortByteString, Text)
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Maybe (ShortByteString, Text)))
-> Maybe (ShortByteString, Text)
forall a. (forall s. ST s a) -> a
runST (Text -> ST s (Maybe (ShortByteString, Text))
forall s. Text -> ST s (Maybe (ShortByteString, Text))
decodeLocalpart Text
t)
    if SB.length lpBytes > 63
        then Left Nothing
        else do
            !domWire <- if T.null rest
                            then Right rootWire
                            else first Just (parseDom rest)
            let !combined = ShortByteString
lpBytes ShortByteString -> ShortByteString -> ShortByteString
forall a. Semigroup a => a -> a -> a
<> ShortByteString
domWire
            maybe (Left Nothing) Right $ wireToDomain combined
  where
    !rootWire :: ShortByteString
rootWire = Word8 -> ShortByteString
SB.singleton Word8
0

----------------------------------------------------------------------
-- Localpart byte walker
----------------------------------------------------------------------

-- | Snapshot of the buffer position when the optimistic @\'\@\'@-mode
-- walker passes an unescaped @\'.\'@.  If the walker reaches
-- end-of-input without seeing an unescaped @\'\@\'@ the snapshot
-- becomes the chosen separator and the localpart is truncated to
-- the bytes that came before the dot.
data DotSnap
    = NoDot
    | DotAt {-# UNPACK #-} !Int  -- ^ buffer position at the dot
            {-# UNPACK #-} !Int  -- ^ source-array offset after the dot

-- | Decode the localpart of a presentation-form mailbox.  Returns
-- the length-prefixed wire-form bytes for the localpart's label
-- (one length byte plus the content bytes) together with the
-- unconsumed remainder of the input (the slice of 'Text' after
-- the separator, or empty if no separator was found).
--
-- 'Nothing' indicates a malformed localpart (bad escape, length
-- overflow, raw @>= 128@ byte from a literal escape).
--
-- The walker chooses the separator by cheap presence-scanning the
-- first 256 bytes of the input for an @\'\@\'@ byte (0x40, which
-- can't appear inside a UTF-8 continuation sequence).  Finding
-- one switches the walker to @\'\@\'@-optimistic mode with a
-- @\'.\'@-snapshot fallback; otherwise the walker uses
-- @\'.\'@-only mode.  The 256-byte window is enough: the largest
-- valid localpart presentation form (63 wire bytes, each encoded
-- as @\\DDD@) fits in 252 bytes plus one for the @\'\@\'@.
decodeLocalpart :: forall s. Text -> ST s (Maybe (ShortByteString, Text))
decodeLocalpart :: forall s. Text -> ST s (Maybe (ShortByteString, Text))
decodeLocalpart (TI.Text ByteArray
src Int
srcOff Int
srcLen) = do
    buf <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
A.newByteArray Int
64
    A.writeByteArray buf 0 (0 :: Word8)
    if firstAtIn srcOff (min 256 srcLen) src
        then loopAt buf 1 NoDot srcOff
        else loopDot buf 1 srcOff
  where
    !srcEnd :: Int
srcEnd = Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
srcLen

    -- @\'\@\'@-optimistic walker.  Records the position of the first
    -- unescaped @\'.\'@ as a fallback in case every @\'\@\'@ is escaped.
    loopAt :: A.MutableByteArray s -> Int -> DotSnap -> Int
           -> ST s (Maybe (ShortByteString, Text))
    loopAt :: MutableByteArray s
-> Int -> DotSnap -> Int -> ST s (Maybe (ShortByteString, Text))
loopAt MutableByteArray s
buf !Int
bufPos !DotSnap
snap !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
srcEnd = case DotSnap
snap of
            DotSnap
NoDot              -> MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf Int
bufPos Int
srcEnd
            DotAt Int
dp Int
dskip     -> MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf Int
dp Int
dskip
      | Bool
otherwise = case ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
src Int
i of
            Word8
0x40  {- '@' -}  -> MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf Int
bufPos (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Word8
0x5C  {- '\\' -} -> case ByteArray -> Int -> Int -> Maybe (Word8, Int)
decodeEscape ByteArray
src (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
srcEnd of
                Maybe (Word8, Int)
Nothing      -> Maybe (ShortByteString, Text)
-> ST s (Maybe (ShortByteString, Text))
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ShortByteString, Text)
forall a. Maybe a
Nothing
                Just (Word8
b, Int
i') -> MutableByteArray s
-> Int
-> Word8
-> ST s (Maybe (ShortByteString, Text))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf Int
bufPos Word8
b
                                  (MutableByteArray s
-> Int -> DotSnap -> Int -> ST s (Maybe (ShortByteString, Text))
loopAt MutableByteArray s
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) DotSnap
snap Int
i')
            Word8
0x2E  {- '.' -}  ->
                let !snap' :: DotSnap
snap' = case DotSnap
snap of
                        DotSnap
NoDot -> Int -> Int -> DotSnap
DotAt Int
bufPos (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                        DotSnap
_     -> DotSnap
snap
                in MutableByteArray s
-> Int
-> Word8
-> ST s (Maybe (ShortByteString, Text))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf Int
bufPos Word8
0x2E
                     (MutableByteArray s
-> Int -> DotSnap -> Int -> ST s (Maybe (ShortByteString, Text))
loopAt MutableByteArray s
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) DotSnap
snap' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80     -> MutableByteArray s
-> Int
-> Word8
-> ST s (Maybe (ShortByteString, Text))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf Int
bufPos Word8
c
                                  (MutableByteArray s
-> Int -> DotSnap -> Int -> ST s (Maybe (ShortByteString, Text))
loopAt MutableByteArray s
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) DotSnap
snap (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
              | Bool
otherwise    -> MutableByteArray s
-> Int
-> Int
-> Word8
-> (Int -> Int -> ST s (Maybe (ShortByteString, Text)))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int
-> Int
-> Word8
-> (Int -> Int -> ST s (Maybe a))
-> ST s (Maybe a)
copyUtf8 MutableByteArray s
buf Int
bufPos Int
i Word8
c ((Int -> Int -> ST s (Maybe (ShortByteString, Text)))
 -> ST s (Maybe (ShortByteString, Text)))
-> (Int -> Int -> ST s (Maybe (ShortByteString, Text)))
-> ST s (Maybe (ShortByteString, Text))
forall a b. (a -> b) -> a -> b
$ \Int
bufPos' Int
i' ->
                                  MutableByteArray s
-> Int -> DotSnap -> Int -> ST s (Maybe (ShortByteString, Text))
loopAt MutableByteArray s
buf Int
bufPos' DotSnap
snap Int
i'

    -- @\'.\'@-only walker (no @\'\@\'@ in the first 256 bytes of input).
    loopDot :: A.MutableByteArray s -> Int -> Int
            -> ST s (Maybe (ShortByteString, Text))
    loopDot :: MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
loopDot MutableByteArray s
buf !Int
bufPos !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
srcEnd = MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf Int
bufPos Int
srcEnd
      | Bool
otherwise = case ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
src Int
i of
            Word8
0x2E  {- '.' -}  -> MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf Int
bufPos (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Word8
0x5C  {- '\\' -} -> case ByteArray -> Int -> Int -> Maybe (Word8, Int)
decodeEscape ByteArray
src (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
srcEnd of
                Maybe (Word8, Int)
Nothing      -> Maybe (ShortByteString, Text)
-> ST s (Maybe (ShortByteString, Text))
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ShortByteString, Text)
forall a. Maybe a
Nothing
                Just (Word8
b, Int
i') -> MutableByteArray s
-> Int
-> Word8
-> ST s (Maybe (ShortByteString, Text))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf Int
bufPos Word8
b
                                  (MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
loopDot MutableByteArray s
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
i')
            Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80     -> MutableByteArray s
-> Int
-> Word8
-> ST s (Maybe (ShortByteString, Text))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf Int
bufPos Word8
c
                                  (MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
loopDot MutableByteArray s
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
              | Bool
otherwise    -> MutableByteArray s
-> Int
-> Int
-> Word8
-> (Int -> Int -> ST s (Maybe (ShortByteString, Text)))
-> ST s (Maybe (ShortByteString, Text))
forall a.
MutableByteArray s
-> Int
-> Int
-> Word8
-> (Int -> Int -> ST s (Maybe a))
-> ST s (Maybe a)
copyUtf8 MutableByteArray s
buf Int
bufPos Int
i Word8
c ((Int -> Int -> ST s (Maybe (ShortByteString, Text)))
 -> ST s (Maybe (ShortByteString, Text)))
-> (Int -> Int -> ST s (Maybe (ShortByteString, Text)))
-> ST s (Maybe (ShortByteString, Text))
forall a b. (a -> b) -> a -> b
$ \Int
bufPos' Int
i' ->
                                  MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
loopDot MutableByteArray s
buf Int
bufPos' Int
i'

    -- Write a single byte at 'bufPos' and continue with @k@.
    -- Rejects writes past the 64-byte buffer (slots 0..63).
    putByte :: A.MutableByteArray s -> Int -> Word8
            -> ST s (Maybe a) -> ST s (Maybe a)
    putByte :: forall a.
MutableByteArray s
-> Int -> Word8 -> ST s (Maybe a) -> ST s (Maybe a)
putByte MutableByteArray s
buf !Int
bufPos !Word8
b ST s (Maybe a)
k
      | Int
bufPos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
63 = Maybe a -> ST s (Maybe a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      | Bool
otherwise   = do MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
buf Int
bufPos Word8
b
                         ST s (Maybe a)
k

    -- Copy a UTF-8 multi-byte sequence (width determined by the
    -- lead byte) from 'src' at offset @i@ into 'buf' at @bufPos@.
    -- The 'Text' input is well-formed UTF-8, so no decoding or
    -- validation is needed: just byte-copy the continuation bytes.
    copyUtf8 :: A.MutableByteArray s -> Int -> Int -> Word8
             -> (Int -> Int -> ST s (Maybe a)) -> ST s (Maybe a)
    copyUtf8 :: forall a.
MutableByteArray s
-> Int
-> Int
-> Word8
-> (Int -> Int -> ST s (Maybe a))
-> ST s (Maybe a)
copyUtf8 MutableByteArray s
buf !Int
bufPos !Int
i !Word8
lead Int -> Int -> ST s (Maybe a)
k
      | Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = Maybe a -> ST s (Maybe a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray @Word8 MutableByteArray s
MutableByteArray (PrimState (ST s))
buf Int
bufPos Word8
lead
          Int -> ST s ()
copyTrailing Int
1
          Int -> Int -> ST s (Maybe a)
k (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width)
      where
        !width :: Int
width
          | Word8
lead Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xC0 = Int
1  -- never hit for well-formed Text
          | Word8
lead Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xE0 = Int
2
          | Word8
lead Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xF0 = Int
3
          | Bool
otherwise   = Int
4
        copyTrailing :: Int -> ST s ()
copyTrailing !Int
j
          | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
width = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          | Bool
otherwise  = do
              MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
buf (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
                  (ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
src (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j))
              Int -> ST s ()
copyTrailing (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

    -- Stamp the length byte at slot 0, copy the used prefix into
    -- a 'ShortByteString', and slice the remaining input.
    finalise :: A.MutableByteArray s -> Int -> Int
             -> ST s (Maybe (ShortByteString, Text))
    finalise :: MutableByteArray s
-> Int -> Int -> ST s (Maybe (ShortByteString, Text))
finalise MutableByteArray s
buf !Int
bufPos !Int
restOff = do
        let !contentLen :: Int
contentLen = Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
buf Int
0 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
contentLen :: Word8)
        let collect :: Int -> [Word8] -> ST s [Word8]
collect !Int
i ![Word8]
acc
              | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = [Word8] -> ST s [Word8]
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word8]
acc
              | Bool
otherwise = do
                  b <- MutableByteArray (PrimState (ST s)) -> Int -> ST s Word8
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
A.readByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
buf Int
i
                  collect (i - 1) (b : acc)
        bytes <- Int -> [Word8] -> ST s [Word8]
collect (Int
bufPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) []
        let !sbs  = [Word8] -> ShortByteString
SB.pack ([Word8]
bytes :: [Word8])
            !rest = ByteArray -> Int -> Int -> Text
TI.Text ByteArray
src Int
restOff (Int
srcEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
restOff)
        pure $ Just (sbs, rest)

-- | True if a @\'\@\'@ byte (0x40) appears anywhere in
-- @arr[off..off+lim-1]@.  Used as a cheap presence test before
-- choosing the localpart walker's separator policy.  An @\'\@\'@
-- is ASCII and so cannot appear inside a UTF-8 multi-byte
-- sequence, so a plain byte scan reliably finds every literal
-- occurrence in the input (escaped ones are also matched, but
-- the walker will reject them and fall back to the
-- @\'.\'@-snapshot).
firstAtIn :: Int -> Int -> TA.Array -> Bool
firstAtIn :: Int -> Int -> ByteArray -> Bool
firstAtIn !Int
off !Int
lim ByteArray
arr = Int -> Bool
go Int
off
  where
    !end :: Int
end = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lim
    go :: Int -> Bool
go !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end                        = Bool
False
      | ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
arr Int
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x40    = Bool
True
      | Bool
otherwise                       = Int -> Bool
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- | Decode a @\\@-escape starting at @arr[off]@ (the byte
-- /after/ the backslash).  Returns the decoded byte and the
-- offset of the byte just past the escape.  Both @\\DDD@
-- (three ASCII decimal digits, @0..127@) and @\\X@ (any other
-- single ASCII byte) decode to a single ASCII byte; values
-- @>= 128@ are rejected.
decodeEscape :: TA.Array -> Int -> Int -> Maybe (Word8, Int)
decodeEscape :: ByteArray -> Int -> Int -> Maybe (Word8, Int)
decodeEscape ByteArray
arr !Int
i !Int
srcEnd
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
srcEnd = Maybe (Word8, Int)
forall a. Maybe a
Nothing
    | !Word8
w <- ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
arr Int
i
    , !Int
d <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x30)
    = if | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0x7f  -> Maybe (Word8, Int)
forall a. Maybe a
Nothing
         | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9     -> (Word8, Int) -> Maybe (Word8, Int)
forall a. a -> Maybe a
Just (Word8
w, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
         | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
srcEnd -> Maybe (Word8, Int)
forall a. Maybe a
Nothing
         | !Int
e <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
arr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x30), Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9
         , !Int
f <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteArray -> Int -> Word8
TA.unsafeIndex ByteArray
arr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x30), Int
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9
         , !Int
n <- Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f :: Int
         , Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80  -> (Word8, Int) -> Maybe (Word8, Int)
forall a. a -> Maybe a
Just (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
         | Bool
otherwise -> Maybe (Word8, Int)
forall a. Maybe a
Nothing

-- | Pack a 'String' to 'Text', rejecting inputs whose UTF-8
-- byte length exceeds @maxBytes@.  Used by 'dnLit' and 'mbLit' to
-- short-circuit obviously-invalid literal inputs before invoking
-- the user parser.
--
-- The implementation uses 'T.unfoldrN' with a codepoint cap of
-- @maxBytes + 1@, which terminates even on infinite input
-- 'String's: a codepoint is at least one UTF-8 byte, so
-- consuming @maxBytes + 1@ codepoints is always sufficient to
-- decide whether the input fits within the @maxBytes@-byte cap.
packBounded :: Int -> String -> Maybe Text
packBounded :: Int -> String -> Maybe Text
packBounded !Int
maxBytes String
s
    | Text -> Int
T.lengthWord8 Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBytes = Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise                  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
  where
    !t :: Text
t = Int -> (String -> Maybe (Char, String)) -> String -> Text
forall a. Int -> (a -> Maybe (Char, a)) -> a -> Text
T.unfoldrN (Int
maxBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
L.uncons String
s

-- | Upper bound on the length of a valid mailbox or domain
-- presentation form, in UTF-8 bytes.  Anything longer is rejected
-- before the parser is invoked.  The worst case is a fully
-- @\\DDD@-escaped 254-octet name with full-width Unicode dots
-- between labels -- still well under 1024 bytes, so this is a
-- generous over-estimate that catches accidental overlong inputs
-- without putting a precise limit on legitimate ones.
mboxPresentationMaxBytes :: Int
mboxPresentationMaxBytes :: Int
mboxPresentationMaxBytes = Int
1024

-- | Template-Haskell typed splice for a compile-time mailbox
-- literal.  Packs the source 'String' literal as 'Text'
-- (rejecting inputs longer than 1024 bytes) and hands it to
-- 'decodePresentationMbox': the localpart is parsed locally with
-- DNS-style escapes, and the post-separator domain text is passed
-- to the caller-supplied parser.  An invalid literal (localpart
-- failure /or/ domain-parser failure /or/ combined-length
-- failure) becomes a compile-time error.
--
-- The parser argument has the same shape as 'dnLit'\'s:
-- @'Text' -> 'Either' e 'ShortByteString'@.  The user can pass
-- the same parser they pass to 'dnLit' (typically a composition
-- with @idna2008@), and the mailbox literal inherits the same IDN
-- policy for the domain portion of the name.  See 'dnLit' for the
-- standard idioms.
mbLit :: forall e m. (Show e, MonadFail m, TH.Quote m)
      => (Text -> Either e ShortByteString) -- ^ Parser
      -> String -- ^ Input literal (source code shape)
      -> TH.Code m Domain
mbLit :: forall e (m :: * -> *).
(Show e, MonadFail m, Quote m) =>
(Text -> Either e ShortByteString) -> String -> Code m Domain
mbLit Text -> Either e ShortByteString
parse String
s = m (Code m Domain) -> Code m Domain
forall (m :: * -> *) a. Monad m => m (Code m a) -> Code m a
TH.joinCode case Int -> String -> Maybe Text
packBounded Int
mboxPresentationMaxBytes String
s of
    Maybe Text
Nothing -> String -> m (Code m Domain)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Code m Domain)) -> String -> m (Code m Domain)
forall a b. (a -> b) -> a -> b
$ String
"Invalid mailbox literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": presentation form longer than "
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mboxPresentationMaxBytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes"
    Just Text
t  -> case (Text -> Either e ShortByteString)
-> Text -> Either (Maybe e) Domain
forall e.
(Text -> Either e ShortByteString)
-> Text -> Either (Maybe e) Domain
decodePresentationMbox Text -> Either e ShortByteString
parse Text
t of
        Left Maybe e
e  -> String -> m (Code m Domain)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Code m Domain)) -> String -> m (Code m Domain)
forall a b. (a -> b) -> a -> b
$ String
"Invalid mailbox literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (e -> String) -> Maybe e -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty e -> String
forall a. Show a => a -> String
show Maybe e
e
        Right Domain
d -> Code m Domain -> m (Code m Domain)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Domain -> Code m Domain
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => Domain -> Code m Domain
TH.liftTyped Domain
d)


-- | Given a 'Domain/, return its label count.  The root domain has zero labels.
--
-- >>> labelCount $$(dnLit8 "example.org")
-- 2
--
-- >>> toLabels $$(mbLit8 "first.last@example.org")
-- 3
--
labelCount :: Domain -> Word
labelCount :: Domain -> Word
labelCount (ShortByteString -> ByteArray
sbsToByteArray (ShortByteString -> ByteArray)
-> (Domain -> ShortByteString) -> Domain -> ByteArray
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ShortByteString
shortBytes -> ByteArray
arr) = Word -> Int -> Word
go Word
0 Int
0
  where
    go :: Word -> Int -> Word
    go :: Word -> Int -> Word
go !Word
acc !Int
off
        | Word8
w <- ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
arr Int
off
        , Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0    = Word -> Int -> Word
go (Word
acc Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
w2i Word8
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = Word
acc

-- | Does the given 'Domain' name consist entirely of LDH labels?
isLDHName :: Domain -> Bool
isLDHName :: Domain -> Bool
isLDHName = [Word8] -> Bool
go ([Word8] -> Bool) -> (Domain -> [Word8]) -> Domain -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> [Word8]
SB.unpack (ShortByteString -> [Word8])
-> (Domain -> ShortByteString) -> Domain -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ShortByteString
shortBytes
  where
    go :: [Word8] -> Bool
    go :: [Word8] -> Bool
go [] = Bool
forall a. a
impossible
    go (Word8
0:[]) = Bool
True
    go (Word8
w:[Word8]
ws)
        | Just [Word8]
rest <- Int -> Int -> [Word8] -> Maybe [Word8]
goLabels Int
0 (Word8 -> Int
w2i Word8
w) [Word8]
ws
          = [Word8] -> Bool
go [Word8]
rest
        | Bool
otherwise = Bool
False

    goLabels :: Int -> Int -> [Word8] -> Maybe [Word8]
    goLabels :: Int -> Int -> [Word8] -> Maybe [Word8]
goLabels !Int
_ !Int
_ [] = Maybe [Word8]
forall a. a
impossible
    goLabels !Int
_ !Int
0 ![Word8]
_ = Maybe [Word8]
forall a. a
impossible
    goLabels !Int
_ Int
1  (!Word8
b:[Word8]
rest)
        | Word8 -> Bool
isLDByte Word8
b = [Word8] -> Maybe [Word8]
forall a. a -> Maybe a
Just [Word8]
rest
        | Bool
otherwise = Maybe [Word8]
forall a. Maybe a
Nothing
    goLabels Int
0 !Int
len  (!Word8
b:[Word8]
bs)
        | Word8 -> Bool
isLDByte Word8
b  = Int -> Int -> [Word8] -> Maybe [Word8]
goLabels Int
1 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
bs
        | Bool
otherwise = Maybe [Word8]
forall a. Maybe a
Nothing
    goLabels !Int
off !Int
len (!Word8
b:[Word8]
bs)
        | Word8 -> Bool
isLDHByte Word8
b = Int -> Int -> [Word8] -> Maybe [Word8]
goLabels (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
bs
        | Bool
otherwise = Maybe [Word8]
forall a. Maybe a
Nothing

-- | Is the given 'ShortByteString' a valid non-empty LDH label?
isLDHLabel :: ShortByteString -> Bool
isLDHLabel :: ShortByteString -> Bool
isLDHLabel = Int -> [Word8] -> Bool
go (Int -> [Word8] -> Bool)
-> (ShortByteString -> Int) -> ShortByteString -> [Word8] -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShortByteString -> Int
SB.length (ShortByteString -> [Word8] -> Bool)
-> (ShortByteString -> [Word8]) -> ShortByteString -> Bool
forall a b.
(ShortByteString -> a -> b)
-> (ShortByteString -> a) -> ShortByteString -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ShortByteString -> [Word8]
SB.unpack
  where
    go :: Int -> [Word8] -> Bool
go Int
len [Word8]
bytes
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64 = Int -> Int -> [Word8] -> Bool
goBytes Int
0 Int
len [Word8]
bytes
        | Bool
otherwise = Bool
False

    goBytes :: Int -> Int -> [Word8] -> Bool
    goBytes :: Int -> Int -> [Word8] -> Bool
goBytes !Int
_ !Int
_ [] = Bool
forall a. a
impossible
    goBytes !Int
_ !Int
0 [Word8]
_  = Bool
forall a. a
impossible
    goBytes !Int
_ !Int
1 (!Word8
b:[Word8]
_) = Word8 -> Bool
isLDByte Word8
b
    goBytes !Int
0 !Int
len (!Word8
b:[Word8]
bs)
        | Word8 -> Bool
isLDByte Word8
b = Int -> Int -> [Word8] -> Bool
goBytes Int
1 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
bs
        | Bool
otherwise = Bool
False
    goBytes !Int
off !Int
len (!Word8
b:[Word8]
bs)
        | Word8 -> Bool
isLDHByte Word8
b = Int -> Int -> [Word8] -> Bool
goBytes (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
bs
        | Bool
otherwise = Bool
False

isLDByte :: Word8 -> Bool
isLDByte :: Word8 -> Bool
isLDByte Word8
w
    | Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x30 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10            = Bool
True
    | (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xdf) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x41 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
26 = Bool
True
    | Bool
otherwise                = Bool
False

isLDHByte :: Word8 -> Bool
isLDHByte :: Word8 -> Bool
isLDHByte Word8
w
    | Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x30 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10            = Bool
True
    | (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xdf) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x41 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
26 = Bool
True
    | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x2d                = Bool
True
    | Bool
otherwise                = Bool
False


-- | Given a 'Domain/, return its constituent list of raw unescaped labels,
-- most-significant (TLD) label last.
--
-- >>> toLabels $$(dnLit8 "example.org")
-- ["example","org"]
--
-- >>> toLabels $$(mbLit8 "first.last@example.org")
-- ["first.last","example","org"]
--
toLabels :: Domain -> [ShortByteString]
toLabels :: Domain -> [ShortByteString]
toLabels (Domain_ ShortByteString
sbs) = Int -> [ShortByteString]
go Int
0
  where
    ba :: ByteArray
ba  = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
sbs
    go :: Int -> [ShortByteString]
go !Int
off
        | Int
llen <- Word8 -> Int
w2i (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
ba Int
off
        , Int
llen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        , ShortByteString
l <- ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Int -> ByteArray
A.cloneByteArray ByteArray
ba (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
llen
          = ShortByteString
l ShortByteString -> [ShortByteString] -> [ShortByteString]
forall a. a -> [a] -> [a]
: Int -> [ShortByteString]
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = []


-- | Given a Domain, return its constituent list of raw unescaped labels in
-- reverse order, with the TLD first.
--
-- >>> revLabels $$(dnLit8 "example.org")
-- ["org","example"]
--
-- >>> revLabels $$(mbLit8 "first.last@example.org")
-- ["org","example","first.last"]
--
revLabels :: Domain -> [ByteString]
revLabels :: Domain -> [ByteString]
revLabels = [ByteString] -> ByteString -> [ByteString]
go [] (ByteString -> [ByteString])
-> (Domain -> ByteString) -> Domain -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ByteString
wireBytes
  where
    go :: [ByteString] -> ByteString -> [ByteString]
go [ByteString]
acc !ByteString
bs
        | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
          = let !llen :: Int
llen = Word8 -> Int
w2i (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
B.unsafeHead ByteString
bs
                !rest :: ByteString
rest = ByteString -> ByteString
B.unsafeTail ByteString
bs
                !lbs :: ByteString
lbs = Int -> ByteString -> ByteString
B.unsafeTake Int
llen ByteString
rest
             in [ByteString] -> ByteString -> [ByteString]
go (ByteString
lbs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc) (Int -> ByteString -> ByteString
B.unsafeDrop Int
llen ByteString
rest)
        | Bool
otherwise
          = [ByteString]
acc


-- | Return the longest common suffix of two input domains.
commonSuffix :: Domain -> Domain -> Domain
commonSuffix :: Domain -> Domain -> Domain
commonSuffix (Domain_ ShortByteString
s1) (Domain_ ShortByteString
s2) = Int -> Int -> Int -> Domain
go (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
len1 Int
len2) Int
0 Int
0
  where
    len1 :: Int
len1 = ShortByteString -> Int
SB.length ShortByteString
s1
    len2 :: Int
len2 = ShortByteString -> Int
SB.length ShortByteString
s2
    ba1 :: ByteArray
ba1  = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
s1
    ba2 :: ByteArray
ba2  = ShortByteString -> ByteArray
sbsToByteArray ShortByteString
s2

    -- When leading labels or suffix lengths are unequal, discard the label
    -- that leaves the shortest suffix, reducing the maximum match size to its
    -- length.  When they're equal, and leave equal length suffixes retain the
    -- match size and continue with both suffixes.  Once either suffix is just
    -- the root domain, we're done.  If both get there at the same time, 'sz'
    -- is the common suffix length.
    go :: Int -> Int -> Int -> Domain
go Int
sz Int
off1 Int
off2
        | Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
i2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          = if | Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i2 Bool -> Bool -> Bool
|| Int
sz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Domain
RootDomain
               | Bool
otherwise           -> Domain
tailSlice
        | Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz
          = Int -> Int -> Int -> Domain
go Int
sz Int
t1 Int
off2
        | Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz
          = Int -> Int -> Int -> Domain
go Int
sz Int
off1 Int
t2
        | Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
r1
          = Int -> Int -> Int -> Domain
go Int
r2 Int
t1 Int
off2
        | Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
r1
          = Int -> Int -> Int -> Domain
go Int
r1 Int
off1 Int
t2
        | Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i2 Bool -> Bool -> Bool
|| Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering
A.compareByteArrays ByteArray
ba1 Int
off1 ByteArray
ba2 Int
off2 Int
i1
          = Int -> Int -> Int -> Domain
go Int
r1 Int
t1 Int
t2
        | Bool
otherwise
          = Int -> Int -> Int -> Domain
go Int
sz Int
t1 Int
t2
      where
        i1 :: Int
i1 = Word8 -> Int
w2i (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
ba1 Int
off1
        t1 :: Int
t1 = Int
off1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        r1 :: Int
r1 = Int
len1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t1
        i2 :: Int
i2 = Word8 -> Int
w2i (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
A.indexByteArray ByteArray
ba2 Int
off2
        t2 :: Int
t2 = Int
off2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        r2 :: Int
r2 = Int
len2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t2
        tailSlice :: Domain
tailSlice = ShortByteString -> Domain
Domain_ (ShortByteString -> Domain) -> ShortByteString -> Domain
forall a b. (a -> b) -> a -> b
$
            ByteArray -> ShortByteString
baToShortByteString (ByteArray -> ShortByteString) -> ByteArray -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Int -> ByteArray
A.cloneByteArray ByteArray
ba1 (Int
len1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
sz


-- | Encode a 'Domain' name without name compression
mbWireForm :: Domain -> SizedBuilder
mbWireForm :: Domain -> SizedBuilder
mbWireForm Domain
d = ShortByteString -> SizedBuilder
mbShortByteString (Domain -> ShortByteString
shortBytes Domain
d)
{-# INLINE mbWireForm #-}

---------------------------------------- Wire -> Presentation

-- | Build the standard (dot-terminated) /presentation form/ of 'Domain'.
presentDomain :: Domain -> Builder -> Builder
presentDomain :: Domain -> Builder -> Builder
presentDomain = (Builder -> Builder) -> Word8 -> Domain -> Builder -> Builder
fromWire Builder -> Builder
dotB Word8
W_dot

-- | Build the /presentation form/ of a 'Domain' without a trailing dot.
-- The root domain is nevertheless presented as a single @.@ byte.
presentHost :: Domain -> Builder -> Builder
presentHost :: Domain -> Builder -> Builder
presentHost = Word8 -> Domain -> Builder -> Builder
toCanonical Word8
W_dot

-- | Build an ad hoc /mailbox form/ of a 'Domain', without a trailing dot,
-- and with @\'\@\'@ as the first label separator.
presentMbox :: Domain -> Builder -> Builder
presentMbox :: Domain -> Builder -> Builder
presentMbox = Word8 -> Domain -> Builder -> Builder
toCanonical Word8
W_at

-- | Build a presentation form.
fromWire :: (Builder -> Builder) -> Word8 -> Domain -> Builder -> Builder
fromWire :: (Builder -> Builder) -> Word8 -> Domain -> Builder -> Builder
fromWire Builder -> Builder
dterm Word8
sep0 (ByteString -> Maybe (Word8, ByteString)
B.uncons (ByteString -> Maybe (Word8, ByteString))
-> (Domain -> ByteString) -> Domain -> Maybe (Word8, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ByteString
wireBytes -> Maybe (Word8, ByteString)
ht) Builder
k
    | Just (Word8
len, ByteString
bs) <- Maybe (Word8, ByteString)
ht = Word8 -> Word8 -> ByteString -> Builder
go Word8
sep0 Word8
len ByteString
bs
    | Bool
otherwise            = Builder
forall a. a
impossible
  where
    go :: Word8 -> Word8 -> ByteString -> Builder
    go :: Word8 -> Word8 -> ByteString -> Builder
go Word8
_   Word8
0   ByteString
_     = Builder -> Builder
dotB Builder
k
    go Word8
sep Word8
len ByteString
bytes =
        let (ByteString
label, ByteString
suffix) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
len) ByteString
bytes
         in case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
suffix of
                Just (Word8
slen, ByteString
sbytes)
                    | Word8
slen Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0 -> Word8 -> ByteString -> Builder -> Builder
presentDomainLabel Word8
sep ByteString
label
                                  (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder -> Builder
presentByte Word8
sep
                                  (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> ByteString -> Builder
go Word8
W_dot Word8
slen ByteString
sbytes
                Maybe (Word8, ByteString)
_   -> Word8 -> ByteString -> Builder -> Builder
presentDomainLabel Word8
W_dot ByteString
label (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder
dterm Builder
k

-- | Build a canonical presentation form (folded to lower case)
toCanonical :: Word8 -> Domain -> Builder -> Builder
toCanonical :: Word8 -> Domain -> Builder -> Builder
toCanonical Word8
sep0 (ByteString -> Maybe (Word8, ByteString)
B.uncons (ByteString -> Maybe (Word8, ByteString))
-> (Domain -> ByteString) -> Domain -> Maybe (Word8, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> ByteString
wireBytes -> Maybe (Word8, ByteString)
ht) Builder
k
    | Just (Word8
len, ByteString
bs) <- Maybe (Word8, ByteString)
ht = Word8 -> Word8 -> ByteString -> Builder
go Word8
sep0 Word8
len ByteString
bs
    | Bool
otherwise            = Builder
forall a. a
impossible
  where
    go :: Word8 -> Word8 -> ByteString -> Builder
    go :: Word8 -> Word8 -> ByteString -> Builder
go Word8
_   Word8
0   ByteString
_     = Builder -> Builder
dotB Builder
k
    go Word8
sep Word8
len ByteString
bytes =
        let (ByteString
label, ByteString
suffix) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
len) ByteString
bytes
         in Word8 -> ByteString -> Builder -> Builder
canon Word8
sep ByteString
label
            (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
suffix of
               Just (Word8
slen, ByteString
sbytes)
                   | Word8
slen Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0 -> Word8 -> Builder -> Builder
presentByte Word8
sep (Word8 -> Word8 -> ByteString -> Builder
go Word8
W_dot Word8
slen ByteString
sbytes)
               Maybe (Word8, ByteString)
_              -> Builder
k
      where
        canon :: Word8 -> ByteString -> Builder -> Builder
canon Word8
W_dot = Word8 -> ByteString -> Builder -> Builder
presentHostLabel Word8
W_dot
        canon Word8
w     = Word8 -> ByteString -> Builder -> Builder
presentDomainLabel Word8
w

---------------------------------------- Util

-- | Most domain names are short, use small buffers, but no need to make them
-- too tight since we ultimately copy again into a short bytestring.
domainStrat :: B.AllocationStrategy
domainStrat :: AllocationStrategy
domainStrat = Int -> Int -> AllocationStrategy
B.untrimmedStrategy Int
32 Int
128

pattern W_dot    :: Word8;      pattern $mW_dot :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
$bW_dot :: Word8
W_dot    = 0x2e
pattern W_at     :: Word8;      pattern $mW_at :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
$bW_at :: Word8
W_at     = 0x40

dotB :: Builder -> Builder
dotB :: Builder -> Builder
dotB = Word8 -> Builder -> Builder
presentByte Word8
W_dot

w2i :: Word8 -> Int
w2i :: Word8 -> Int
w2i = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE w2i #-}

i2w :: Int -> Word8
i2w :: Int -> Word8
i2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE i2w #-}

-- | Upper case ASCII letter?
{-# INLINE isupper #-}
isupper :: Word8 -> Bool
isupper :: Word8 -> Bool
isupper Word8
w = (Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x41 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
26)

-- | Map upper case ASCII to lower case.
{-# INLINE tolower #-}
tolower :: Word8 -> Word8
tolower :: Word8 -> Word8
tolower Word8
w | Word8 -> Bool
isupper Word8
w = Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
32
tolower Word8
w = Word8
w