Parameters.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

module Network.QUIC.Parameters (
    Parameters (..),
    defaultParameters,
    baseParameters, -- only for Connection
    encodeParameters,
    decodeParameters,
    AuthCIDs (..),
    defaultAuthCIDs,
    setCIDsToParameters,
    getCIDsToParameters,
) where

import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import qualified Data.ByteString.Short as Short
import Network.Control
import System.IO.Unsafe (unsafeDupablePerformIO)

import Network.QUIC.Imports
import Network.QUIC.Types

encodeParameters :: Parameters -> ByteString
encodeParameters = encodeParameterList . toParameterList

decodeParameters :: ByteString -> Maybe Parameters
decodeParameters bs = decodeParameterList bs >>= fromParameterList

newtype Key = Key Word32 deriving (Eq, Show)
type Value = ByteString

type ParameterList = [(Key, Value)]

{- FOURMOLU_DISABLE -}
pattern OriginalDestinationConnectionId :: Key
pattern OriginalDestinationConnectionId  = Key 0x00
pattern MaxIdleTimeout                  :: Key
pattern MaxIdleTimeout                   = Key 0x01
pattern StateLessResetToken             :: Key
pattern StateLessResetToken              = Key 0x02
pattern MaxUdpPayloadSize               :: Key
pattern MaxUdpPayloadSize                = Key 0x03
pattern InitialMaxData                  :: Key
pattern InitialMaxData                   = Key 0x04
pattern InitialMaxStreamDataBidiLocal   :: Key
pattern InitialMaxStreamDataBidiLocal    = Key 0x05
pattern InitialMaxStreamDataBidiRemote  :: Key
pattern InitialMaxStreamDataBidiRemote   = Key 0x06
pattern InitialMaxStreamDataUni         :: Key
pattern InitialMaxStreamDataUni          = Key 0x07
pattern InitialMaxStreamsBidi           :: Key
pattern InitialMaxStreamsBidi            = Key 0x08
pattern InitialMaxStreamsUni            :: Key
pattern InitialMaxStreamsUni             = Key 0x09
pattern AckDelayExponent                :: Key
pattern AckDelayExponent                 = Key 0x0a
pattern MaxAckDelay                     :: Key
pattern MaxAckDelay                      = Key 0x0b
pattern DisableActiveMigration          :: Key
pattern DisableActiveMigration           = Key 0x0c
pattern PreferredAddress                :: Key
pattern PreferredAddress                 = Key 0x0d
pattern ActiveConnectionIdLimit         :: Key
pattern ActiveConnectionIdLimit          = Key 0x0e
pattern InitialSourceConnectionId       :: Key
pattern InitialSourceConnectionId        = Key 0x0f
pattern RetrySourceConnectionId         :: Key
pattern RetrySourceConnectionId          = Key 0x10
pattern VersionInformation              :: Key
pattern VersionInformation               = Key 0x11
pattern MaxDatagramFrameSize            :: Key
pattern MaxDatagramFrameSize             = Key 0x20
pattern Grease                          :: Key
pattern Grease                           = Key 0xff
pattern GreaseQuicBit                   :: Key
pattern GreaseQuicBit                    = Key 0x2ab2
{- FOURMOLU_ENABLE -}

-- | QUIC transport parameters.
data Parameters = Parameters
    { originalDestinationConnectionId :: Maybe CID
    , maxIdleTimeout :: Milliseconds
    , statelessResetToken :: Maybe StatelessResetToken -- 16 bytes
    , maxUdpPayloadSize :: Int
    , initialMaxData :: Int
    , initialMaxStreamDataBidiLocal :: Int
    , initialMaxStreamDataBidiRemote :: Int
    , initialMaxStreamDataUni :: Int
    , initialMaxStreamsBidi :: Int
    , initialMaxStreamsUni :: Int
    , ackDelayExponent :: Int
    , maxAckDelay :: Milliseconds
    , disableActiveMigration :: Bool
    , preferredAddress :: Maybe ByteString -- fixme
    , activeConnectionIdLimit :: Int
    , initialSourceConnectionId :: Maybe CID
    , retrySourceConnectionId :: Maybe CID
    , grease :: Maybe ByteString
    , greaseQuicBit :: Bool
    , versionInformation :: Maybe VersionInfo
    , maxDatagramFrameSize :: Int
    }
    deriving (Eq, Show)

-- | The default value for QUIC transport parameters.
baseParameters :: Parameters
baseParameters =
    Parameters
        { originalDestinationConnectionId = Nothing
        , maxIdleTimeout = Milliseconds 0 -- disabled
        , statelessResetToken = Nothing
        , maxUdpPayloadSize = 65527
        , initialMaxData = 0
        , initialMaxStreamDataBidiLocal = 0
        , initialMaxStreamDataBidiRemote = 0
        , initialMaxStreamDataUni = 0
        , initialMaxStreamsBidi = 0
        , initialMaxStreamsUni = 0
        , ackDelayExponent = 3
        , maxAckDelay = Milliseconds 25
        , disableActiveMigration = False
        , preferredAddress = Nothing
        , activeConnectionIdLimit = 2
        , initialSourceConnectionId = Nothing
        , retrySourceConnectionId = Nothing
        , grease = Nothing
        , greaseQuicBit = False
        , versionInformation = Nothing
        , maxDatagramFrameSize = 0
        }

-- | The value of an integer transport parameter, or 'Nothing' if the octets
--   given are not one.
--
-- RFC 9000 section 18 gives these values as a single variable-length integer,
-- so anything else is malformed: a value too short to hold the integer it
-- announces, an empty one, or one with octets left over behind the integer it
-- does hold.  'decodeInt' answers the first two by reading off the end, which
-- from inside 'unsafeDupablePerformIO' means an exception out of a pure value
-- -- raised wherever the field is first forced, which is nowhere near here.
decInt :: ByteString -> Maybe Int
decInt bs = unsafeDupablePerformIO $
    E.handle (\BufferOverrun -> return Nothing) $
        withReadBuffer bs $ \rbuf -> do
            n <- decodeInt' rbuf
            rest <- remainingSize rbuf
            return $ if rest == 0 then Just (fromIntegral n) else Nothing

encInt :: Int -> ByteString
encInt = encodeInt . fromIntegral

decMilliseconds :: ByteString -> Maybe Milliseconds
decMilliseconds bs = Milliseconds . fromIntegral <$> decInt bs

encMilliseconds :: Milliseconds -> ByteString
encMilliseconds (Milliseconds n) = encodeInt $ fromIntegral n

fromVersionInfo :: Maybe VersionInfo -> Value
fromVersionInfo Nothing = "" -- never reach
fromVersionInfo (Just VersionInfo{..}) = unsafeDupablePerformIO $
    withWriteBuffer len $ \wbuf -> do
        let putVersion (Version ver) = write32 wbuf ver
        putVersion chosenVersion
        mapM_ putVersion otherVersions
  where
    len = 4 * (length otherVersions + 1)

toVersionInfo :: Value -> Maybe VersionInfo
toVersionInfo bs
    | len < 3 || remainder /= 0 = Just brokenVersionInfo
    | otherwise = Just $
        unsafeDupablePerformIO $
            withReadBuffer bs $ \rbuf -> do
                let getVersion = Version <$> read32 rbuf
                VersionInfo <$> getVersion <*> replicateM (cnt - 1) getVersion
  where
    len = BS.length bs
    (cnt, remainder) = len `divMod` 4

-- | 'Nothing' if any parameter's value is malformed, or if any parameter is
--   sent twice.  An unknown /key/ is neither: RFC 9000 section 18.1 says to
--   ignore one.
--
-- Section 7.4.2 on the repetition: \"An endpoint MUST treat receipt of a
-- duplicate transport parameter as a connection error of type
-- TRANSPORT_PARAMETER_ERROR.\"  Being unknown is not an exemption -- an
-- unknown parameter is ignored once, not permitted twice -- so the check is
-- on the key as it arrived, before anything decides whether it means
-- something here.
fromParameterList :: ParameterList -> Maybe Parameters
fromParameterList kvs0 = go IntSet.empty params kvs0
  where
    params = baseParameters
    go :: IntSet -> Parameters -> ParameterList -> Maybe Parameters
    go _ x [] = Just x
    go seen x (kv@(Key k, _) : kvs)
        | key `IntSet.member` seen = Nothing
        | otherwise = do
            x' <- update x kv
            go (IntSet.insert key seen) x' kvs
      where
        key = fromIntegral k
    update x (OriginalDestinationConnectionId, v) =
        Just x{originalDestinationConnectionId = Just (toCID v)}
    update x (MaxIdleTimeout, v) =
        (\n -> x{maxIdleTimeout = n}) <$> decMilliseconds v
    update x (StateLessResetToken, v) =
        Just x{statelessResetToken = Just (StatelessResetToken $ Short.toShort v)}
    update x (MaxUdpPayloadSize, v) =
        (\n -> x{maxUdpPayloadSize = n}) <$> decInt v
    update x (InitialMaxData, v) =
        (\n -> x{initialMaxData = n}) <$> decInt v
    update x (InitialMaxStreamDataBidiLocal, v) =
        (\n -> x{initialMaxStreamDataBidiLocal = n}) <$> decInt v
    update x (InitialMaxStreamDataBidiRemote, v) =
        (\n -> x{initialMaxStreamDataBidiRemote = n}) <$> decInt v
    update x (InitialMaxStreamDataUni, v) =
        (\n -> x{initialMaxStreamDataUni = n}) <$> decInt v
    update x (InitialMaxStreamsBidi, v) =
        (\n -> x{initialMaxStreamsBidi = n}) <$> decInt v
    update x (InitialMaxStreamsUni, v) =
        (\n -> x{initialMaxStreamsUni = n}) <$> decInt v
    update x (AckDelayExponent, v) =
        (\n -> x{ackDelayExponent = n}) <$> decInt v
    update x (MaxAckDelay, v) =
        (\n -> x{maxAckDelay = n}) <$> decMilliseconds v
    update x (DisableActiveMigration, _) =
        Just x{disableActiveMigration = True}
    update x (PreferredAddress, v) =
        Just x{preferredAddress = Just v}
    update x (ActiveConnectionIdLimit, v) =
        (\n -> x{activeConnectionIdLimit = n}) <$> decInt v
    update x (InitialSourceConnectionId, v) =
        Just x{initialSourceConnectionId = Just (toCID v)}
    update x (RetrySourceConnectionId, v) =
        Just x{retrySourceConnectionId = Just (toCID v)}
    update x (Grease, v) =
        Just x{grease = Just v}
    update x (GreaseQuicBit, _) =
        Just x{greaseQuicBit = True}
    update x (VersionInformation, v) =
        Just x{versionInformation = toVersionInfo v}
    update x (MaxDatagramFrameSize, v) =
        (\n -> x{maxDatagramFrameSize = n}) <$> decInt v
    update x _ = Just x

diff
    :: Eq a
    => Parameters
    -> (Parameters -> a)
    -> Key
    -> (a -> Value)
    -> Maybe (Key, Value)
diff params label key enc
    | val == val0 = Nothing
    | otherwise = Just (key, enc val)
  where
    val = label params
    val0 = label baseParameters

toParameterList :: Parameters -> ParameterList
toParameterList p =
    catMaybes
        [ diff
            p
            originalDestinationConnectionId
            OriginalDestinationConnectionId
            (fromCID . fromJust)
        , diff p maxIdleTimeout MaxIdleTimeout encMilliseconds
        , diff p statelessResetToken StateLessResetToken encSRT
        , diff p maxUdpPayloadSize MaxUdpPayloadSize encInt
        , diff p initialMaxData InitialMaxData encInt
        , diff p initialMaxStreamDataBidiLocal InitialMaxStreamDataBidiLocal encInt
        , diff p initialMaxStreamDataBidiRemote InitialMaxStreamDataBidiRemote encInt
        , diff p initialMaxStreamDataUni InitialMaxStreamDataUni encInt
        , diff p initialMaxStreamsBidi InitialMaxStreamsBidi encInt
        , diff p initialMaxStreamsUni InitialMaxStreamsUni encInt
        , diff p ackDelayExponent AckDelayExponent encInt
        , diff p maxAckDelay MaxAckDelay encMilliseconds
        , diff p disableActiveMigration DisableActiveMigration (const "")
        , diff p preferredAddress PreferredAddress fromJust
        , diff p activeConnectionIdLimit ActiveConnectionIdLimit encInt
        , diff
            p
            initialSourceConnectionId
            InitialSourceConnectionId
            (fromCID . fromJust)
        , diff
            p
            retrySourceConnectionId
            RetrySourceConnectionId
            (fromCID . fromJust)
        , diff p greaseQuicBit GreaseQuicBit (const "")
        , diff p grease Grease fromJust
        , diff p versionInformation VersionInformation fromVersionInfo
        , diff p maxDatagramFrameSize MaxDatagramFrameSize encInt
        ]

encSRT :: Maybe StatelessResetToken -> ByteString
encSRT (Just (StatelessResetToken srt)) = Short.fromShort srt
encSRT _ = error "encSRT"

encodeParameterList :: ParameterList -> ByteString
encodeParameterList kvs = unsafeDupablePerformIO $
    withWriteBuffer 4096 $ \wbuf -> do
        -- for grease
        mapM_ (put wbuf) kvs
  where
    put wbuf (Key k, v) = do
        encodeInt' wbuf $ fromIntegral k
        encodeInt' wbuf $ fromIntegral $ BS.length v
        copyByteString wbuf v

-- | The transport parameters a peer sent, or 'Nothing' if they are not a
--   whole list.  A key, a length and that many octets, repeated until the
--   octets run out; anything that stops in the middle of one of those reads
--   off the end.
decodeParameterList :: ByteString -> Maybe ParameterList
decodeParameterList bs =
    unsafeDupablePerformIO $
        E.handle (\BufferOverrun -> return Nothing) $
            withReadBuffer bs (`go` id)
  where
    go rbuf build = do
        rest1 <- remainingSize rbuf
        if rest1 == 0
            then return $ Just (build [])
            else do
                key <- fromIntegral <$> decodeInt' rbuf
                len <- fromIntegral <$> decodeInt' rbuf
                val <- extractByteString rbuf len
                go rbuf (build . ((Key key, val) :))

-- | An example parameters obsoleted in the near future.
--
-- >>> defaultParameters
-- Parameters {originalDestinationConnectionId = Nothing, maxIdleTimeout = 30000, statelessResetToken = Nothing, maxUdpPayloadSize = 2048, initialMaxData = 16777216, initialMaxStreamDataBidiLocal = 262144, initialMaxStreamDataBidiRemote = 262144, initialMaxStreamDataUni = 262144, initialMaxStreamsBidi = 64, initialMaxStreamsUni = 3, ackDelayExponent = 3, maxAckDelay = 25, disableActiveMigration = False, preferredAddress = Nothing, activeConnectionIdLimit = 5, initialSourceConnectionId = Nothing, retrySourceConnectionId = Nothing, grease = Nothing, greaseQuicBit = True, versionInformation = Nothing, maxDatagramFrameSize = 0}
defaultParameters :: Parameters
defaultParameters =
    baseParameters
        { maxIdleTimeout = idleTimeout -- 30000
        , maxUdpPayloadSize = maximumUdpPayloadSize -- 2048
        , initialMaxData = defaultMaxData -- !M
        , initialMaxStreamDataBidiLocal = defaultMaxStreamData -- 256K
        , initialMaxStreamDataBidiRemote = defaultMaxStreamData -- 256K
        , initialMaxStreamDataUni = defaultMaxStreamData -- 256K
        , initialMaxStreamsBidi = defaultMaxStreams -- 64
        , initialMaxStreamsUni = 3
        , activeConnectionIdLimit = 5
        , greaseQuicBit = True
        , maxDatagramFrameSize = 0
        }

data AuthCIDs = AuthCIDs
    { initSrcCID :: Maybe CID
    , origDstCID :: Maybe CID
    , retrySrcCID :: Maybe CID
    }
    deriving (Eq, Show)

defaultAuthCIDs :: AuthCIDs
defaultAuthCIDs = AuthCIDs Nothing Nothing Nothing

setCIDsToParameters :: AuthCIDs -> Parameters -> Parameters
setCIDsToParameters AuthCIDs{..} params =
    params
        { originalDestinationConnectionId = origDstCID
        , initialSourceConnectionId = initSrcCID
        , retrySourceConnectionId = retrySrcCID
        }

getCIDsToParameters :: Parameters -> AuthCIDs
getCIDsToParameters Parameters{..} =
    AuthCIDs
        { origDstCID = originalDestinationConnectionId
        , initSrcCID = initialSourceConnectionId
        , retrySrcCID = retrySourceConnectionId
        }