{-|
Module      : Net.DNSBase.RData.SVCB.SVCParamValue
Description : Typed values for SVCB / HTTPS service-parameter keys
Copyright   : (c) Viktor Dukhovni, 2026
License     : BSD-3-Clause
Maintainer  : ietf-dane@dukhovni.org
Stability   : unstable

An @SVCB@ or @HTTPS@ record carries a list of (key, value) service
parameters.  Each key has its own value type, so the value side is
structured as an extensible typeclass 'KnownSVCParamValue' with
one instance per standardised key, wrapped in an existential
'SVCParamValue' so a single list can hold a heterogeneous mix.
Unknown keys fall through to 'OpaqueSPV', which preserves the raw
wire bytes for later inspection or pass-through.

Applications can add a new service-parameter type at runtime by
writing a 'KnownSVCParamValue' instance and installing it via
'Net.DNSBase.Resolver.extendRRwithType' on the @SVCB@ or @HTTPS@
RR type — see "Net.DNSBase.Extensible" for a worked example.
-}

module Net.DNSBase.RData.SVCB.SVCParamValue
    ( KnownSVCParamValue(..)
    , SVCParamValue(..)
    , fromSPV
    , serviceParamKey
      -- Representation of unknown parameters
    , OpaqueSPV(..)
    , opaqueSPV
    , toOpaqueSPV
    ) where

import qualified Data.ByteString.Short as SB
import Net.DNSBase.Internal.Util

import Net.DNSBase.Decode.State
import Net.DNSBase.Encode.State
import Net.DNSBase.Nat16
import Net.DNSBase.Present
import Net.DNSBase.RData.SVCB.SVCParamKey
import Net.DNSBase.Text

-- * Generic SVC Field-Value

-- | The class of types representing the value side of a service
-- parameter inside an @SVCB@ or @HTTPS@ record.  Each instance
-- corresponds to a specific 'SVCParamKey'; the 'encodeSPV' and
-- 'decodeSPV' methods handle only the value bytes.  The
-- surrounding @(key, length)@ frame is owned by the SVCB-record
-- encoder: 'encodeSPV' writes just the payload, and the framework
-- wraps the result in the 2-byte length prefix.
-- For value-less parameters this means 'encodeSPV' is just
-- @pure ()@.
--
-- The 'Presentable' instance builds the RFC 9460 zone-file
-- presentation form: the key name followed (where the value is
-- non-empty) by @=@ and the value.  The 'Show' instance is
-- typically derived and aims to produce syntactically valid
-- Haskell.
class (Typeable a, Eq a, Ord a, Show a, Presentable a) => KnownSVCParamValue a where
    -- | The associated key number
    spvKey     :: forall b -> b ~ a => SVCParamKey
    -- | CPS presentation form builder for the key
    spvKeyPres :: forall b -> b ~ a => Builder -> Builder
    -- | Encode value to wire form
    encodeSPV  :: forall r s. ErrorContext r => a -> SPut s r
    -- | Decode value from wire form
    decodeSPV  :: forall b -> b ~ a => Int -> SGet SVCParamValue

    -- | Override to get user-friendly output for runtime-added types.
    -- Otherwise, defaults to @key@/number/.
    spvKeyPres _ = SVCParamKey -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present (spvKey a)


-- | Existential wrapper around any 'KnownSVCParamValue', so a
-- single list can hold a mix of typed service parameters.  The
-- 'present' method delegates to the underlying instance, which
-- emits both the key name and the value.
data SVCParamValue = forall a. KnownSVCParamValue a => SVCParamValue a

-- | Extract specific known 'SVCParamValue' from existential wrapping
fromSPV :: forall a. KnownSVCParamValue a => SVCParamValue -> Maybe a
fromSPV :: forall a. KnownSVCParamValue a => SVCParamValue -> Maybe a
fromSPV (SVCParamValue a
a) = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a

svcParamValueKey :: SVCParamValue -> SVCParamKey
svcParamValueKey :: SVCParamValue -> SVCParamKey
svcParamValueKey (SVCParamValue (a
_ :: t)) = spvKey t
{-# INLINE svcParamValueKey #-}

-- | Perform a default encoding of the contained 'KnownSVCParamValue'.
spvEncode :: ErrorContext r => SVCParamValue -> SPut s r
spvEncode :: forall r s. ErrorContext r => SVCParamValue -> SPut s r
spvEncode (SVCParamValue a
a) = a -> SPut s r
forall a r s.
(KnownSVCParamValue a, ErrorContext r) =>
a -> SPut s r
forall r s. ErrorContext r => a -> SPut s r
encodeSPV a
a

-- | Key associated with a generic SvcParamValue
serviceParamKey :: SVCParamValue -> SVCParamKey
serviceParamKey :: SVCParamValue -> SVCParamKey
serviceParamKey (SVCParamValue (a
_ :: t)) = spvKey t

instance Eq SVCParamValue where
    (SVCParamValue (a
_a :: a)) == :: SVCParamValue -> SVCParamValue -> Bool
== (SVCParamValue (a
_b :: b))
        | spvKey a SVCParamKey -> SVCParamKey -> Bool
forall a. Eq a => a -> a -> Bool
/= spvKey b = Bool
False
        | Just a :~: a
Refl <- teq a b = a
_a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
_b
        | Bool
otherwise = Bool
False

-- | Compare first by key number, then by content.
-- When two key numbers match, but the data types nevertheless differ, order
-- opaque type after non-opaque.  In the unlikely case of two non-opaque types
-- with the same key, compare their opaque encodings (this could throw an error
-- if one of the objects is not encodable, perhaps because encoding would be
-- too long).
instance Ord SVCParamValue where
    compare :: SVCParamValue -> SVCParamValue -> Ordering
compare sa :: SVCParamValue
sa@(SVCParamValue (a
_a :: a)) sb :: SVCParamValue
sb@(SVCParamValue (a
_b :: b)) =
        SVCParamKey -> SVCParamKey -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (spvKey a) (spvKey b)
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> if | Just a :~: a
Refl <- teq a b -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
_a a
a
_b
              | SVCParamKey -> SVCParamValue -> Bool
isOpaque (spvKey a) SVCParamValue
sa -> Ordering
GT
              | SVCParamKey -> SVCParamValue -> Bool
isOpaque (spvKey b) SVCParamValue
sb -> Ordering
LT
              | Bool
otherwise              -> Either (EncodeErr (Maybe ())) SVCParamValue
-> Either (EncodeErr (Maybe ())) SVCParamValue -> Ordering
forall {a} {a} {a}.
(Ord a, Show a, Show a) =>
Either a a -> Either a a -> Ordering
ocmp (SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue
toOpaqueSPV SVCParamValue
sa) (SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue
toOpaqueSPV SVCParamValue
sb)
      where
        ocmp :: Either a a -> Either a a -> Ordering
ocmp (Right a
oa) (Right a
ob) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
oa a
ob
        ocmp (Left a
e)   Either a a
_          = [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ordering) -> [Char] -> Ordering
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
e
        ocmp Either a a
_          (Left a
e)   = [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ordering) -> [Char] -> Ordering
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
e

instance Show SVCParamValue where
    showsPrec :: Int -> SVCParamValue -> ShowS
showsPrec Int
p (SVCParamValue a
a) =
        Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
            [Char] -> ShowS
showString [Char]
"SVCParamValue "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
a
      where
        app_prec :: Int
app_prec = Int
10

instance Presentable SVCParamValue where
    present :: SVCParamValue -> Builder -> Builder
present (SVCParamValue a
a)  = a -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present a
a

-- | Fallback carrier for service-parameter values whose key code
-- has no 'KnownSVCParamValue' instance registered.  The key code
-- is encoded as a type-level natural so 'OpaqueSPV' values with
-- different codes have distinct types.  The wire payload is kept
-- as raw bytes and round-trips losslessly; the presentation form
-- is @keyN=...@ with the value as a 'DnsText' character-string.
data OpaqueSPV n where
     OpaqueSPV :: Nat16 n => SB.ShortByteString -> OpaqueSPV n
deriving instance Eq (OpaqueSPV n)
deriving instance Ord (OpaqueSPV n)
deriving instance Show (OpaqueSPV n)

instance Nat16 n => KnownSVCParamValue (OpaqueSPV n) where
    spvKey :: forall b -> (b ~ OpaqueSPV n) => SVCParamKey
spvKey _ = Word16 -> SVCParamKey
SVCParamKey (Word16 -> SVCParamKey) -> Word16 -> SVCParamKey
forall a b. (a -> b) -> a -> b
$ natToWord16 n
    encodeSPV :: forall r s. ErrorContext r => OpaqueSPV n -> SPut s r
encodeSPV (OpaqueSPV ShortByteString
txt) = ShortByteString -> SPut s r
forall r s. ErrorContext r => ShortByteString -> SPut s r
putShortByteString ShortByteString
txt
    decodeSPV :: forall b -> (b ~ OpaqueSPV n) => Int -> SGet SVCParamValue
decodeSPV _ = OpaqueSPV n -> SVCParamValue
forall a. KnownSVCParamValue a => a -> SVCParamValue
SVCParamValue (OpaqueSPV n -> SVCParamValue)
-> (ShortByteString -> OpaqueSPV n)
-> ShortByteString
-> SVCParamValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). Nat16 n => ShortByteString -> OpaqueSPV n
OpaqueSPV @n (ShortByteString -> SVCParamValue)
-> (Int -> SGet ShortByteString) -> Int -> SGet SVCParamValue
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Int -> SGet ShortByteString
getShortNByteString

instance Nat16 n => Presentable (OpaqueSPV n) where
    present :: OpaqueSPV n -> Builder -> Builder
present (OpaqueSPV ShortByteString
v) =
        [Char] -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present [Char]
"key" (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present (natToWord16 n)
        -- Empty values suppressed
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Builder)
-> (Builder -> Builder) -> Bool -> Builder -> Builder
forall a. a -> a -> Bool -> a
bool Builder -> Builder
forall a. a -> a
id (forall a. Presentable a => Char -> a -> Builder -> Builder
presentCharSep @DnsText Char
'=' (ShortByteString -> DnsText
forall a b. Coercible a b => a -> b
coerce ShortByteString
v)) ((ShortByteString -> Int
SB.length ShortByteString
v) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)

-- | Build an 'SVCParamValue' from a raw numeric key and a raw
-- byte payload.  Useful when a caller has a wire encoding for a
-- key that has no registered 'KnownSVCParamValue' instance, or
-- when round-tripping bytes for keys that should remain
-- uninterpreted.
opaqueSPV :: Word16 -> SB.ShortByteString -> SVCParamValue
opaqueSPV :: Word16 -> ShortByteString -> SVCParamValue
opaqueSPV Word16
w ShortByteString
bs = Word16
-> (forall (n :: Nat) -> Nat16 n => SVCParamValue) -> SVCParamValue
forall r. Word16 -> (forall (n :: Nat) -> Nat16 n => r) -> r
withNat16 Word16
w forall (n :: Nat) -> Nat16 n => SVCParamValue
go
  where
    go :: forall (n :: Nat) -> Nat16 n => SVCParamValue
    go :: forall (n :: Nat) -> Nat16 n => SVCParamValue
go n = OpaqueSPV n -> SVCParamValue
forall a. KnownSVCParamValue a => a -> SVCParamValue
SVCParamValue (OpaqueSPV n -> SVCParamValue) -> OpaqueSPV n -> SVCParamValue
forall a b. (a -> b) -> a -> b
$ (ShortByteString -> OpaqueSPV n
forall (n :: Nat). Nat16 n => ShortByteString -> OpaqueSPV n
OpaqueSPV ShortByteString
bs :: OpaqueSPV n)

-- | Encode an 'SVCParamValue' to its 'OpaqueSPV' equivalent under
-- the same key code.  Values that are already opaque are returned
-- unchanged.  For typed values this re-encodes the payload to
-- wire form; encoding can fail (for example if the result would
-- be too long to fit a 16-bit length field), in which case the
-- 'EncodeErr' is returned.
toOpaqueSPV :: SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue
toOpaqueSPV :: SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue
toOpaqueSPV s :: SVCParamValue
s@(SVCParamValue -> SVCParamKey
svcParamValueKey -> SVCParamKey
k) = Word16
-> (forall (n :: Nat) ->
    Nat16 n => Either (EncodeErr (Maybe ())) SVCParamValue)
-> Either (EncodeErr (Maybe ())) SVCParamValue
forall r. Word16 -> (forall (n :: Nat) -> Nat16 n => r) -> r
withNat16 (SVCParamKey -> Word16
forall a b. Coercible a b => a -> b
coerce SVCParamKey
k) forall (n :: Nat) ->
Nat16 n => Either (EncodeErr (Maybe ())) SVCParamValue
go
  where
    go :: forall (n :: Nat) -> Nat16 n
       => Either (EncodeErr (Maybe ())) SVCParamValue
    go :: forall (n :: Nat) ->
Nat16 n => Either (EncodeErr (Maybe ())) SVCParamValue
go n | SVCParamKey -> SVCParamValue -> Bool
isOpaque SVCParamKey
k SVCParamValue
s = SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue
forall a b. b -> Either a b
Right SVCParamValue
s
         | Bool
otherwise
           = OpaqueSPV n -> SVCParamValue
forall a. KnownSVCParamValue a => a -> SVCParamValue
SVCParamValue (OpaqueSPV n -> SVCParamValue)
-> (ByteString -> OpaqueSPV n) -> ByteString -> SVCParamValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> OpaqueSPV n
mkopaque (ByteString -> SVCParamValue)
-> Either (EncodeErr (Maybe ())) ByteString
-> Either (EncodeErr (Maybe ())) SVCParamValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. SPut s ()) -> Either (EncodeErr (Maybe ())) ByteString
forall r.
ErrorContext r =>
(forall s. SPut s r) -> Either (EncodeErr (Maybe r)) ByteString
encodeVerbatim do SVCParamValue -> SPut s ()
forall r s. ErrorContext r => SVCParamValue -> SPut s r
spvEncode SVCParamValue
s
             where
               -- Raw value bytes (the SVCB framework supplies the
               -- 2-byte length prefix on the wire, but here we are
               -- capturing just the payload for opaque storage).
               mkopaque :: ByteString -> OpaqueSPV n
               mkopaque :: ByteString -> OpaqueSPV n
mkopaque ByteString
bs = ShortByteString -> OpaqueSPV n
forall (n :: Nat). Nat16 n => ShortByteString -> OpaqueSPV n
OpaqueSPV (ShortByteString -> OpaqueSPV n) -> ShortByteString -> OpaqueSPV n
forall a b. (a -> b) -> a -> b
$ ByteString -> ShortByteString
SB.toShort ByteString
bs

-- | Check whether the given 'SVCParamValue is opaque of given key.
--
isOpaque :: SVCParamKey -> SVCParamValue -> Bool
isOpaque :: SVCParamKey -> SVCParamValue -> Bool
isOpaque SVCParamKey
k SVCParamValue
spv = Word16 -> (forall (n :: Nat) -> Nat16 n => Bool) -> Bool
forall r. Word16 -> (forall (n :: Nat) -> Nat16 n => r) -> r
withNat16 (SVCParamKey -> Word16
forall a b. Coercible a b => a -> b
coerce SVCParamKey
k) forall (n :: Nat) -> Nat16 n => Bool
go
  where
    go :: forall (n :: Nat) -> Nat16 n => Bool
    go :: forall (n :: Nat) -> Nat16 n => Bool
go n = Maybe (OpaqueSPV n) -> Bool
forall a. Maybe a -> Bool
isJust (SVCParamValue -> Maybe (OpaqueSPV n)
forall a. KnownSVCParamValue a => SVCParamValue -> Maybe a
fromSPV SVCParamValue
spv :: Maybe (OpaqueSPV n))