{-|
Module      : Net.DNSBase.RData.WKS
Description : Well-Known Services (obsolete)
Copyright   : (c) Viktor Dukhovni, 2026
License     : BSD-3-Clause
Maintainer  : ietf-dane@dukhovni.org
Stability   : unstable

The @WKS@ resource record predates port-by-port service discovery
conventions and was effectively obsoleted by them.  It is defined
here so wire-form parsers can read stray @WKS@ records in zone
data without failing; new deployments should not produce @WKS@.
-}
{-# LANGUAGE RecordWildCards #-}

module Net.DNSBase.RData.WKS
    ( T_wks(..)
    , WksProto(.., UDP, TCP)
    ) where

import qualified Data.Set as Set
import qualified Data.Primitive.ByteArray as A
import Data.Set (Set, fromAscList)
import Net.DNSBase.Internal.Util

import Net.DNSBase.Decode.State
import Net.DNSBase.Encode.State
import Net.DNSBase.Present
import Net.DNSBase.RData
import Net.DNSBase.RRTYPE

-- | IP protocol number used in the 'T_wks' header byte.  Bidirectional
-- patterns 'TCP' (6) and 'UDP' (17) cover the two protocols @WKS@
-- was ever realistically used for; any other protocol number
-- presents as its decimal value.
newtype WksProto = WksProto Word8
    deriving newtype (WksProto -> WksProto -> Bool
(WksProto -> WksProto -> Bool)
-> (WksProto -> WksProto -> Bool) -> Eq WksProto
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WksProto -> WksProto -> Bool
== :: WksProto -> WksProto -> Bool
$c/= :: WksProto -> WksProto -> Bool
/= :: WksProto -> WksProto -> Bool
Eq, Eq WksProto
Eq WksProto =>
(WksProto -> WksProto -> Ordering)
-> (WksProto -> WksProto -> Bool)
-> (WksProto -> WksProto -> Bool)
-> (WksProto -> WksProto -> Bool)
-> (WksProto -> WksProto -> Bool)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> Ord WksProto
WksProto -> WksProto -> Bool
WksProto -> WksProto -> Ordering
WksProto -> WksProto -> WksProto
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 :: WksProto -> WksProto -> Ordering
compare :: WksProto -> WksProto -> Ordering
$c< :: WksProto -> WksProto -> Bool
< :: WksProto -> WksProto -> Bool
$c<= :: WksProto -> WksProto -> Bool
<= :: WksProto -> WksProto -> Bool
$c> :: WksProto -> WksProto -> Bool
> :: WksProto -> WksProto -> Bool
$c>= :: WksProto -> WksProto -> Bool
>= :: WksProto -> WksProto -> Bool
$cmax :: WksProto -> WksProto -> WksProto
max :: WksProto -> WksProto -> WksProto
$cmin :: WksProto -> WksProto -> WksProto
min :: WksProto -> WksProto -> WksProto
Ord, WksProto
WksProto -> WksProto -> Bounded WksProto
forall a. a -> a -> Bounded a
$cminBound :: WksProto
minBound :: WksProto
$cmaxBound :: WksProto
maxBound :: WksProto
Bounded, Int -> WksProto
WksProto -> Int
WksProto -> [WksProto]
WksProto -> WksProto
WksProto -> WksProto -> [WksProto]
WksProto -> WksProto -> WksProto -> [WksProto]
(WksProto -> WksProto)
-> (WksProto -> WksProto)
-> (Int -> WksProto)
-> (WksProto -> Int)
-> (WksProto -> [WksProto])
-> (WksProto -> WksProto -> [WksProto])
-> (WksProto -> WksProto -> [WksProto])
-> (WksProto -> WksProto -> WksProto -> [WksProto])
-> Enum WksProto
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: WksProto -> WksProto
succ :: WksProto -> WksProto
$cpred :: WksProto -> WksProto
pred :: WksProto -> WksProto
$ctoEnum :: Int -> WksProto
toEnum :: Int -> WksProto
$cfromEnum :: WksProto -> Int
fromEnum :: WksProto -> Int
$cenumFrom :: WksProto -> [WksProto]
enumFrom :: WksProto -> [WksProto]
$cenumFromThen :: WksProto -> WksProto -> [WksProto]
enumFromThen :: WksProto -> WksProto -> [WksProto]
$cenumFromTo :: WksProto -> WksProto -> [WksProto]
enumFromTo :: WksProto -> WksProto -> [WksProto]
$cenumFromThenTo :: WksProto -> WksProto -> WksProto -> [WksProto]
enumFromThenTo :: WksProto -> WksProto -> WksProto -> [WksProto]
Enum, Integer -> WksProto
WksProto -> WksProto
WksProto -> WksProto -> WksProto
(WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto)
-> (WksProto -> WksProto)
-> (WksProto -> WksProto)
-> (Integer -> WksProto)
-> Num WksProto
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WksProto -> WksProto -> WksProto
+ :: WksProto -> WksProto -> WksProto
$c- :: WksProto -> WksProto -> WksProto
- :: WksProto -> WksProto -> WksProto
$c* :: WksProto -> WksProto -> WksProto
* :: WksProto -> WksProto -> WksProto
$cnegate :: WksProto -> WksProto
negate :: WksProto -> WksProto
$cabs :: WksProto -> WksProto
abs :: WksProto -> WksProto
$csignum :: WksProto -> WksProto
signum :: WksProto -> WksProto
$cfromInteger :: Integer -> WksProto
fromInteger :: Integer -> WksProto
Num, Num WksProto
Ord WksProto
(Num WksProto, Ord WksProto) =>
(WksProto -> Rational) -> Real WksProto
WksProto -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: WksProto -> Rational
toRational :: WksProto -> Rational
Real, Enum WksProto
Real WksProto
(Real WksProto, Enum WksProto) =>
(WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> WksProto)
-> (WksProto -> WksProto -> (WksProto, WksProto))
-> (WksProto -> WksProto -> (WksProto, WksProto))
-> (WksProto -> Integer)
-> Integral WksProto
WksProto -> Integer
WksProto -> WksProto -> (WksProto, WksProto)
WksProto -> WksProto -> WksProto
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: WksProto -> WksProto -> WksProto
quot :: WksProto -> WksProto -> WksProto
$crem :: WksProto -> WksProto -> WksProto
rem :: WksProto -> WksProto -> WksProto
$cdiv :: WksProto -> WksProto -> WksProto
div :: WksProto -> WksProto -> WksProto
$cmod :: WksProto -> WksProto -> WksProto
mod :: WksProto -> WksProto -> WksProto
$cquotRem :: WksProto -> WksProto -> (WksProto, WksProto)
quotRem :: WksProto -> WksProto -> (WksProto, WksProto)
$cdivMod :: WksProto -> WksProto -> (WksProto, WksProto)
divMod :: WksProto -> WksProto -> (WksProto, WksProto)
$ctoInteger :: WksProto -> Integer
toInteger :: WksProto -> Integer
Integral, Int -> WksProto -> ShowS
[WksProto] -> ShowS
WksProto -> String
(Int -> WksProto -> ShowS)
-> (WksProto -> String) -> ([WksProto] -> ShowS) -> Show WksProto
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WksProto -> ShowS
showsPrec :: Int -> WksProto -> ShowS
$cshow :: WksProto -> String
show :: WksProto -> String
$cshowList :: [WksProto] -> ShowS
showList :: [WksProto] -> ShowS
Show, ReadPrec [WksProto]
ReadPrec WksProto
Int -> ReadS WksProto
ReadS [WksProto]
(Int -> ReadS WksProto)
-> ReadS [WksProto]
-> ReadPrec WksProto
-> ReadPrec [WksProto]
-> Read WksProto
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WksProto
readsPrec :: Int -> ReadS WksProto
$creadList :: ReadS [WksProto]
readList :: ReadS [WksProto]
$creadPrec :: ReadPrec WksProto
readPrec :: ReadPrec WksProto
$creadListPrec :: ReadPrec [WksProto]
readListPrec :: ReadPrec [WksProto]
Read)

pattern TCP :: WksProto; pattern $mTCP :: forall {r}. WksProto -> ((# #) -> r) -> ((# #) -> r) -> r
$bTCP :: WksProto
TCP = WksProto 6
pattern UDP :: WksProto; pattern $mUDP :: forall {r}. WksProto -> ((# #) -> r) -> ((# #) -> r) -> r
$bUDP :: WksProto
UDP = WksProto 17

instance Presentable WksProto where
    present :: WksProto -> Builder -> Builder
present WksProto
UDP = forall a. Presentable a => a -> Builder -> Builder
present @String String
"UDP"
    present WksProto
TCP = forall a. Presentable a => a -> Builder -> Builder
present @String String
"TCP"
    present WksProto
p   = forall a. Presentable a => a -> Builder -> Builder
present @Word8 (Word8 -> Builder -> Builder) -> Word8 -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ WksProto -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral WksProto
p

-- | The @WKS@ resource record
-- ([RFC 1035 section 3.4.2](https://datatracker.ietf.org/doc/html/rfc1035#section-3.4.2)),
-- mapping an 'IPv4' address and a 'WksProto' protocol number to the
-- set of TCP/UDP port numbers (16-bit) on which the named host
-- accepts connections.  Ports are encoded on the wire as a packed
-- bitmap whose length implies the maximum port carried.
--
-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-- >  |                    ADDRESS                    |
-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-- >  |       PROTOCOL        |                       |
-- >  +--+--+--+--+--+--+--+--+                       |
-- >  |                                               |
-- >  /                   <BIT MAP>                   /
-- >  /                                               /
-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
--
-- The 'Ord' instance compares by address, then protocol, then
-- the port set in descending order — matching the byte-wise
-- comparison of the wire-form port bitmap, so it agrees with the
-- canonical RR-content ordering of
-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).
data T_wks = T_WKS
    { T_wks -> IPv4
wksAddr4 :: IPv4       -- ^ Host IPv4 address
    , T_wks -> WksProto
wksProto :: WksProto   -- ^ IP protocol number
    , T_wks -> Set Word16
wksPorts :: Set Word16 -- ^ Set of port numbers
    } deriving (T_wks -> T_wks -> Bool
(T_wks -> T_wks -> Bool) -> (T_wks -> T_wks -> Bool) -> Eq T_wks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: T_wks -> T_wks -> Bool
== :: T_wks -> T_wks -> Bool
$c/= :: T_wks -> T_wks -> Bool
/= :: T_wks -> T_wks -> Bool
Eq, Int -> T_wks -> ShowS
[T_wks] -> ShowS
T_wks -> String
(Int -> T_wks -> ShowS)
-> (T_wks -> String) -> ([T_wks] -> ShowS) -> Show T_wks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> T_wks -> ShowS
showsPrec :: Int -> T_wks -> ShowS
$cshow :: T_wks -> String
show :: T_wks -> String
$cshowList :: [T_wks] -> ShowS
showList :: [T_wks] -> ShowS
Show)

instance Ord T_wks where
    T_wks
a compare :: T_wks -> T_wks -> Ordering
`compare` T_wks
b = T_wks -> IPv4
wksAddr4 T_wks
a IPv4 -> IPv4 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` T_wks -> IPv4
wksAddr4 T_wks
b
                 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> T_wks -> WksProto
wksProto T_wks
a WksProto -> WksProto -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` T_wks -> WksProto
wksProto T_wks
b
                 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> T_wks -> [Down Word16]
portlist T_wks
a [Down Word16] -> [Down Word16] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` T_wks -> [Down Word16]
portlist T_wks
b
      where
        portlist :: T_wks -> [Down Word16]
        portlist :: T_wks -> [Down Word16]
portlist = [Word16] -> [Down Word16]
forall a b. Coercible a b => a -> b
coerce ([Word16] -> [Down Word16])
-> (T_wks -> [Word16]) -> T_wks -> [Down Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word16 -> [Word16]
forall a. Set a -> [a]
Set.toList (Set Word16 -> [Word16])
-> (T_wks -> Set Word16) -> T_wks -> [Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T_wks -> Set Word16
wksPorts

instance Presentable T_wks where
    present :: T_wks -> Builder -> Builder
present T_WKS{Set Word16
IPv4
WksProto
wksAddr4 :: T_wks -> IPv4
wksProto :: T_wks -> WksProto
wksPorts :: T_wks -> Set Word16
wksAddr4 :: IPv4
wksProto :: WksProto
wksPorts :: Set Word16
..} =
        IPv4 -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present          IPv4
wksAddr4
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WksProto -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp      WksProto
wksProto
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word16 -> Builder -> Builder
forall {a}. Presentable a => Set a -> Builder -> Builder
presentSpPorts Set Word16
wksPorts
      where
        presentSpPorts :: Set a -> Builder -> Builder
presentSpPorts (Set a -> [a]
forall a. Set a -> [a]
Set.toList -> [a]
ports) =
            forall a. Presentable a => a -> Builder -> Builder
present @String String
" ("
            (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> [a] -> Builder) -> [a] -> Builder -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> Builder -> Builder) -> Builder -> [a] -> Builder
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp) [a]
ports
            (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Presentable a => a -> Builder -> Builder
present @String String
" )"

instance KnownRData T_wks where
    rdType :: forall b -> (b ~ T_wks) => RRTYPE
rdType _ = RRTYPE
WKS
    {-# INLINE rdType #-}
    rdEncode :: forall s. T_wks -> SPut s RData
rdEncode T_WKS{Set Word16
IPv4
WksProto
wksAddr4 :: T_wks -> IPv4
wksProto :: T_wks -> WksProto
wksPorts :: T_wks -> Set Word16
wksAddr4 :: IPv4
wksProto :: WksProto
wksPorts :: Set Word16
..} = do
        IPv4 -> SPut s RData
forall r s. ErrorContext r => IPv4 -> SPut s r
putIPv4 IPv4
wksAddr4
        Word8 -> SPut s RData
forall r s. ErrorContext r => Word8 -> SPut s r
put8 (Word8 -> SPut s RData) -> Word8 -> SPut s RData
forall a b. (a -> b) -> a -> b
$ WksProto -> Word8
forall a b. Coercible a b => a -> b
coerce WksProto
wksProto
        Set Word16 -> SPut s RData
forall s. Set Word16 -> SPut s RData
putPortBitmap Set Word16
wksPorts
    rdDecode :: forall b ->
(b ~ T_wks) => RDataExtensionVal T_wks -> Int -> SGet RData
rdDecode _ RDataExtensionVal T_wks
_ Int
len = do
        wksAddr4 <- SGet IPv4
getIPv4
        wksProto <- WksProto <$> get8
        wksPorts <- getPortBitmap (len - 5)
        pure $ RData T_WKS{..}

getPortBitmap :: Int -> SGet (Set Word16)
getPortBitmap :: Int -> SGet (Set Word16)
getPortBitmap Int
len
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x2000 = String -> SGet (Set Word16)
forall a. String -> SGet a
failSGet String
"WKS bitmap too long"
    | Bool
otherwise    = [Word16] -> Set Word16
forall a. Eq a => [a] -> Set a
fromAscList ([Word16] -> Set Word16)
-> ([Word8] -> [Word16]) -> [Word8] -> Set Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> [Word8] -> [Word16]
go Word16
0 ([Word8] -> Set Word16) -> SGet [Word8] -> SGet (Set Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> SGet [Word8]
getNBytes Int
len
  where
    go :: Word16 -> [Word8] -> [Word16]
    go :: Word16 -> [Word8] -> [Word16]
go !Word16
off (Word8
w : [Word8]
ws)
        | Int
z <- Word8 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word8
w
        , Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
        , Word16
port <- Word16
off Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
z
          = Word16
port Word16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
: Word16 -> [Word8] -> [Word16]
go Word16
off (Word8
w Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` (Int
7Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
z) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
ws)
        | Bool
otherwise = Word16 -> [Word8] -> [Word16]
go (Word16
off Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
8) [Word8]
ws
    go Word16
_ [Word8]
_ = []

putPortBitmap :: Set Word16 -> SPut s RData
putPortBitmap :: forall s. Set Word16 -> SPut s RData
putPortBitmap Set Word16
s
    | Set Word16 -> Bool
forall a. Set a -> Bool
Set.null Set Word16
s = () -> SPutM s RData ()
forall a. a -> SPutM s RData a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise  = ShortByteString -> SPutM s RData ()
forall r s. ErrorContext r => ShortByteString -> SPut s r
putShortByteString ShortByteString
sbs
  where
    top :: Int
top = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Set Word16 -> Word16
forall a. Set a -> a
Set.findMax Set Word16
s Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
    sbs :: ShortByteString
sbs = ByteArray -> ShortByteString
baToShortByteString ByteArray
bitmap
      where
        bitmap :: ByteArray
        bitmap :: ByteArray
bitmap = (forall s. ST s (MutableByteArray s)) -> ByteArray
A.runByteArray do
            a <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
A.newByteArray (Int -> ST s (MutableByteArray (PrimState (ST s))))
-> Int -> ST s (MutableByteArray (PrimState (ST s)))
forall a b. (a -> b) -> a -> b
$ Int
top Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            A.fillByteArray a 0 (top + 1) 0
            sequence_
                [ modifyArray a byte (`setBit` bitpos)
                | t <- Set.toList s
                , let it = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
t
                , let byte = (Int
it Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3)
                , let bitpos = Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
it Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7) ]
            pure a