-- |
-- Module      : Net.DNSBase.EDNS.Internal.Option
-- Description : TBD
-- Copyright   : (c) Viktor Dukhovni, 2026
-- License     : BSD-3-Clause
-- Maintainer  : ietf-dane@dukhovni.org
-- Stability   : unstable
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
module Net.DNSBase.EDNS.Internal.Option
    ( -- * EDNS option class
      KnownEdnsOption(..)
    , EdnsOption(..)
    , fromOption
    , monoOption
    , optionCode
    , putOption
    -- * EDNS option Controls
    , OptionCtl
    , optCtlSet
    , optCtlAdd
    , emptyOptionCtl
    , applyOptionCtl
    -- * Extensibility
    , OptionCodec(..)
    ) where

import Data.List (sortOn)

import Net.DNSBase.Decode.Internal.State
import Net.DNSBase.EDNS.Internal.OptNum
import Net.DNSBase.Encode.Internal.State
import Net.DNSBase.Internal.Present
import Net.DNSBase.Internal.Util

-- | EDNS option class with conversion to/from opaque 'EdnsOption' form.
class (Typeable a, Eq a, Show a, Presentable a) => KnownEdnsOption a where
    -- | The codec-consumed extension value for option type @a@.
    -- Defaults to @()@.  Options with a non-trivial extension
    -- (currently only 'Net.DNSBase.EDNS.Option.EDE.O_ede', whose extension carries the
    -- info-code name registry) supply their own associated-type
    -- definition.
    type OptionExtensionVal a :: Type
    type OptionExtensionVal a = ()

    -- | The library's built-in starting 'OptionExtensionVal' for option
    -- type @a@.  Used as the baseline when the library installs
    -- its built-in registration for @a@, and as the starting
    -- point when the user extends the codec for @a@.  For
    -- @'OptionExtensionVal' a ~ ()@ options the class default applies.
    optionExtensionVal :: forall b -> b ~ a => OptionExtensionVal a
    default optionExtensionVal :: (OptionExtensionVal a ~ ())
                               => forall b -> b ~ a
                               => OptionExtensionVal a
    optionExtensionVal _ = ()

    -- | The EDNS option number
    optNum     :: forall b -> b ~ a => OptNum

    -- | CPS option number presentation form builder.
    -- Most useful for new option values not yet known to the library.
    optPres    :: forall b -> b ~ a => Builder -> Builder

    -- | Encoder of option data to wire form
    optEncode  :: forall s r. (Typeable r, Eq r, Show r)
               => a -- ^ The value to encode
               -> SPut s r

    -- | Decoder from wire form
    optDecode  :: forall b
               -> b ~ a
               -- ^ The type to decode
               => OptionExtensionVal b
               -- ^ Its extension value
               -> Int
               -- ^ The encoded data length
               -> SGet EdnsOption

    optPres t = OptNum -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present (OptNum -> Builder -> Builder) -> OptNum -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ optNum t
    {-# INLINE optPres #-}


-- | Known EDNS option Proxy + 'OptionExtensionVal' pair, paralleling
-- 'Net.DNSBase.Internal.RData.RDataCodec' on the RR-type side.
data OptionCodec where
    OptionCodec :: KnownEdnsOption a
                => Proxy a
                -> OptionExtensionVal a
                -> OptionCodec

-- | Existentially quantified type-opaque 'KnownEdnsOption', with heterogeneous
-- equality.
data EdnsOption = forall a. KnownEdnsOption a => EdnsOption a

-- | Extract specific 'KnownEdnsOption' from existential wrapping
fromOption :: forall a. KnownEdnsOption a => EdnsOption -> Maybe a
fromOption :: forall a. KnownEdnsOption a => EdnsOption -> Maybe a
fromOption (EdnsOption a
a) = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a
{-# INLINE fromOption #-}

instance Show EdnsOption where
    showsPrec :: Int -> EdnsOption -> ShowS
showsPrec Int
p (EdnsOption a
a)  = Int -> ShowS -> ShowS
showsP Int
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"EdnsOption " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows' a
a

instance Presentable EdnsOption where
    present :: EdnsOption -> Builder -> Builder
present (EdnsOption a
a)  = a -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present a
a
    {-# INLINE present #-}

instance Eq EdnsOption where
    (EdnsOption (a
_a :: a)) == :: EdnsOption -> EdnsOption -> Bool
== (EdnsOption (a
_b :: b)) =
        case teq a b of
            Just a :~: a
Refl -> a
_a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
_b
            Maybe (a :~: a)
_         -> Bool
False

-- | The 16-bit 'Net.DNSBase.EDNS.OptNum.OptNum' codepoint of the option wrapped inside a
-- 'EdnsOption'.  Useful for filtering or grouping a heterogeneous
-- option list without unpacking each value.
optionCode :: EdnsOption -> OptNum
optionCode :: EdnsOption -> OptNum
optionCode (EdnsOption (a
_ :: a)) = optNum a
{-# INLINE optionCode #-}

-- | Filter a 'Foldable' of 'EdnsOption' down to the values of a
-- single type @a@, dropping any entries whose option-code does
-- not match (or whose value is held under an 'Net.DNSBase.EDNS.Option.Opaque.OpaqueOption' even
-- though @a@ is registered for that code).  Use a type
-- application to select the target type, e.g. @'monoOption' \@'Net.DNSBase.EDNS.Option.EDE.O_ede'
-- ednsOptions@.
monoOption :: forall a t. (KnownEdnsOption a, Foldable t) => t EdnsOption -> [a]
monoOption :: forall a (t :: * -> *).
(KnownEdnsOption a, Foldable t) =>
t EdnsOption -> [a]
monoOption = (EdnsOption -> [a] -> [a]) -> [a] -> t EdnsOption -> [a]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (:) (Maybe a -> [a] -> [a])
-> (EdnsOption -> Maybe a) -> EdnsOption -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdnsOption -> Maybe a
forall a. KnownEdnsOption a => EdnsOption -> Maybe a
fromOption) []
{-# INLINE monoOption #-}

-- | Wire-form encoder for a 'EdnsOption': writes the 16-bit
-- option code followed by the length-prefixed value bytes
-- produced by the underlying 'optEncode' method.  Used by the
-- OPT pseudo-RR encoder to serialise each option in turn.
putOption :: forall s r. (Typeable r, Eq r, Show r)
          => EdnsOption -> SPut s r
putOption :: forall s r. (Typeable r, Eq r, Show r) => EdnsOption -> SPut s r
putOption (EdnsOption (a
o :: a)) = do
    Word16 -> SPut s r
forall r s. ErrorContext r => Word16 -> SPut s r
put16 (Word16 -> SPut s r) -> Word16 -> SPut s r
forall a b. (a -> b) -> a -> b
$ OptNum -> Word16
forall a b. Coercible a b => a -> b
coerce (optNum a)
    SPut s r -> SPut s r
forall r s a. ErrorContext r => SPutM s r a -> SPutM s r a
passLen (a -> SPut s r
forall a s r.
(KnownEdnsOption a, Typeable r, Eq r, Show r) =>
a -> SPut s r
forall s r. (Typeable r, Eq r, Show r) => a -> SPut s r
optEncode a
o)
{-# INLINE putOption #-}

--------

-- | The list of EDNS options carried in the OPT pseudo-RR of an
-- outgoing query.  Callers do not build an 'OptionCtl' directly;
-- they build an endomorphism @'OptionCtl' -> 'OptionCtl'@ out of
-- 'optCtlAdd' and 'optCtlSet' and pass it to the 'Net.DNSBase.Resolver.EdnsOptionCtl'
-- pattern of 'Net.DNSBase.Resolver.QueryControls'.  The endomorphism is applied to the
-- resolver's ambient option list at send time, so callers see the
-- final list as a delta on top of whatever the resolver already
-- had configured.
newtype OptionCtl = OptionCtl { OptionCtl -> [EdnsOption]
fromOptionCtl :: [EdnsOption] }
    deriving (OptionCtl -> OptionCtl -> Bool
(OptionCtl -> OptionCtl -> Bool)
-> (OptionCtl -> OptionCtl -> Bool) -> Eq OptionCtl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OptionCtl -> OptionCtl -> Bool
== :: OptionCtl -> OptionCtl -> Bool
$c/= :: OptionCtl -> OptionCtl -> Bool
/= :: OptionCtl -> OptionCtl -> Bool
Eq, Int -> OptionCtl -> ShowS
[OptionCtl] -> ShowS
OptionCtl -> String
(Int -> OptionCtl -> ShowS)
-> (OptionCtl -> String)
-> ([OptionCtl] -> ShowS)
-> Show OptionCtl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OptionCtl -> ShowS
showsPrec :: Int -> OptionCtl -> ShowS
$cshow :: OptionCtl -> String
show :: OptionCtl -> String
$cshowList :: [OptionCtl] -> ShowS
showList :: [OptionCtl] -> ShowS
Show)

-- | Replace the option list outright with the supplied options.
-- Use this when the per-call configuration should override
-- anything the resolver had set; combine with 'optCtlAdd' for
-- partial overrides.
optCtlSet :: [EdnsOption] -> OptionCtl -> OptionCtl
optCtlSet :: [EdnsOption] -> OptionCtl -> OptionCtl
optCtlSet [EdnsOption]
opts OptionCtl
_ = [EdnsOption] -> OptionCtl
OptionCtl ((EdnsOption -> OptNum) -> [EdnsOption] -> [EdnsOption]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn EdnsOption -> OptNum
optionCode [EdnsOption]
opts)

-- | Add the supplied options to the existing list.  When the new
-- and old options share an @OPTCODE@, the new entries replace the
-- old ones with that code.
optCtlAdd :: [EdnsOption] -> OptionCtl -> OptionCtl
optCtlAdd :: [EdnsOption] -> OptionCtl -> OptionCtl
optCtlAdd [EdnsOption]
opts (OptionCtl [EdnsOption]
opts') = [EdnsOption] -> OptionCtl
OptionCtl ([EdnsOption] -> OptionCtl) -> [EdnsOption] -> OptionCtl
forall a b. (a -> b) -> a -> b
$ [EdnsOption] -> [EdnsOption] -> [EdnsOption]
lbMerge ((EdnsOption -> OptNum) -> [EdnsOption] -> [EdnsOption]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn EdnsOption -> OptNum
optionCode [EdnsOption]
opts) [EdnsOption]
opts'
  where
    -- left-biased merge that omits duplicate opcodes in the second argument only
    lbMerge :: [EdnsOption] -> [EdnsOption] -> [EdnsOption]
lbMerge [] [EdnsOption]
ys = [EdnsOption]
ys
    lbMerge [EdnsOption]
xs [] = [EdnsOption]
xs
    lbMerge xs :: [EdnsOption]
xs@(EdnsOption
x:[EdnsOption]
xt) ys :: [EdnsOption]
ys@(EdnsOption
y:[EdnsOption]
yt) =
        case OptNum -> OptNum -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (EdnsOption -> OptNum
optionCode EdnsOption
x) (EdnsOption -> OptNum
optionCode EdnsOption
y) of
            Ordering
LT -> EdnsOption
x EdnsOption -> [EdnsOption] -> [EdnsOption]
forall a. a -> [a] -> [a]
: [EdnsOption] -> [EdnsOption] -> [EdnsOption]
lbMerge [EdnsOption]
xt [EdnsOption]
ys
            Ordering
GT -> EdnsOption
y EdnsOption -> [EdnsOption] -> [EdnsOption]
forall a. a -> [a] -> [a]
: [EdnsOption] -> [EdnsOption] -> [EdnsOption]
lbMerge [EdnsOption]
xs [EdnsOption]
yt
            Ordering
EQ -> [EdnsOption] -> [EdnsOption] -> [EdnsOption]
lbMerge [EdnsOption]
xs [EdnsOption]
yt

-- | The empty option list.  Useful as the seed when running an
-- 'OptionCtl' endomorphism to inspect what it would produce.
emptyOptionCtl :: OptionCtl
emptyOptionCtl :: OptionCtl
emptyOptionCtl = [EdnsOption] -> OptionCtl
OptionCtl []

-- | Apply an 'OptionCtl' endomorphism to a plain list of options.
-- Used by the resolver to fold per-call EDNS-option tweaks into
-- the option list it is about to put on the wire.
applyOptionCtl :: (OptionCtl -> OptionCtl) -> [EdnsOption] -> [EdnsOption]
applyOptionCtl :: (OptionCtl -> OptionCtl) -> [EdnsOption] -> [EdnsOption]
applyOptionCtl OptionCtl -> OptionCtl
f [EdnsOption]
opts = OptionCtl -> [EdnsOption]
fromOptionCtl (OptionCtl -> [EdnsOption]) -> OptionCtl -> [EdnsOption]
forall a b. (a -> b) -> a -> b
$ OptionCtl -> OptionCtl
f ([EdnsOption] -> OptionCtl
OptionCtl [EdnsOption]
opts)