quic 0.3.1 → 0.3.2

raw patch · 27 files changed

+489/−13 lines, 27 filesdep ~stmdep ~unix-time

Dependency ranges changed: stm, unix-time

Files

• ChangeLog.md +5/−0
• Network/QUIC.hs +4/−0
• Network/QUIC/Client.hs +1/−0
• Network/QUIC/Client/Run.hs +3/−0
• Network/QUIC/Config.hs +4/−0
• Network/QUIC/Connection/Misc.hs +1/−0
• Network/QUIC/Connection/Role.hs +1/−0
• Network/QUIC/Connection/State.hs +6/−0
• Network/QUIC/Connection/Types.hs +18/−4
• Network/QUIC/Handshake.hs +18/−1
• Network/QUIC/IO.hs +41/−0
• Network/QUIC/Info.hs +3/−0
• Network/QUIC/Packet/Frame.hs +24/−1
• Network/QUIC/Parameters.hs +9/−1
• Network/QUIC/Qlog.hs +2/−0
• Network/QUIC/Receiver.hs +11/−0
• Network/QUIC/Sender.hs +1/−0
• Network/QUIC/Server.hs +1/−0
• Network/QUIC/Server/Run.hs +2/−0
• Network/QUIC/Types/Exception.hs +1/−0
• Network/QUIC/Types/Frame.hs +1/−0
• Network/QUIC/Types/Info.hs +4/−0
• Network/QUIC/Types/Resumption.hs +2/−0
• quic.cabal +3/−1
• test/Config.hs +1/−1
• test/DatagramSpec.hs +314/−0
• test/PacketSpec.hs +8/−4

@@ -1,5 +1,10 @@ # ChangeLog +## 0.3.2++* Support Unreliable Datagrams extension (RFC9221)+  [#92](https://github.com/kazu-yamamoto/quic/pull/92)+ ## 0.3.1  * Using tls v2.4.0.

@@ -34,6 +34,10 @@     recvStream,     sendStream,     sendStreamMany,+    sendDatagram,+    recvDatagram,+    recvDatagramMany,+    recvDatagramSTM,      -- * Information     ConnectionInfo,

@@ -12,6 +12,7 @@     ccPortName,     ccALPN,     ccUse0RTT,+    ccMaxDatagramFrameSize,     ccResumption,     ccCiphers,     ccGroups,

@@ -10,6 +10,7 @@ ) where  import Control.Concurrent+import Control.Concurrent.STM import Control.Concurrent.Async import qualified Control.Exception as E import Foreign.C.Types@@ -139,6 +140,7 @@     let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID}         peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID}     genSRT <- makeGenStatelessReset+    connRecvDatagramQ <- newTQueueIO     conn <-         clientConnection             conf@@ -151,6 +153,7 @@             sref             piref             q+            connRecvDatagramQ             send             recv             genSRT

@@ -90,6 +90,7 @@     , ccTlsHooks :: ClientHooks     , ccUse0RTT :: Bool     -- ^ Use 0-RTT on the 2nd connection if possible.+    , ccMaxDatagramFrameSize :: Int     -- client original     --     -- Default: 'False'@@ -149,6 +150,7 @@         , ccHooks = defaultHooks         , ccTlsHooks = defaultClientHooks         , ccUse0RTT = False+        , ccMaxDatagramFrameSize = 0         , -- client original           ccServerName = "127.0.0.1"         , ccPortName = "4433"@@ -185,6 +187,7 @@     , scHooks :: Hooks     , scTlsHooks :: ServerHooks     , scUse0RTT :: Bool+    , scMaxDatagramFrameSize :: Int     -- ^ Use 0-RTT on the 2nd connection if possible.     -- server original     , scAddresses :: [(IP, PortNumber)]@@ -219,6 +222,7 @@         , scHooks = defaultHooks         , scTlsHooks = defaultServerHooks         , scUse0RTT = False+        , scMaxDatagramFrameSize = 0         , -- server original           scAddresses = [("0.0.0.0", 4433), ("::", 4433)]         , scALPN = Nothing

@@ -147,6 +147,7 @@         , initialMaxStreamDataUni = resumptionInitialMaxStreamDataUni         , initialMaxStreamsBidi = resumptionInitialMaxStreamsBidi         , initialMaxStreamsUni = resumptionInitialMaxStreamsUni+        , maxDatagramFrameSize = resumptionMaxDatagramFrameSize         }  ----------------------------------------------------------------

@@ -127,6 +127,7 @@         , resumptionInitialMaxStreamDataUni = initialMaxStreamDataUni         , resumptionInitialMaxStreamsBidi = initialMaxStreamsBidi         , resumptionInitialMaxStreamsUni = initialMaxStreamsUni+        , resumptionMaxDatagramFrameSize = maxDatagramFrameSize         }  ----------------------------------------------------------------

@@ -2,6 +2,7 @@  module Network.QUIC.Connection.State (     setConnection0RTTReady,+    isConnection0RTTReady,     isConnection1RTTReady,     setConnection1RTTReady,     isConnectionEstablished,@@ -57,6 +58,11 @@ setConnectionClosed conn = setConnectionState conn Closed  ----------------------------------------------------------------++isConnection0RTTReady :: Connection -> IO Bool+isConnection0RTTReady Connection{..} = atomically $ do+    st <- readTVar $ connectionState connState+    return (st >= ReadyFor0RTT && st /= Closed)  isConnection1RTTReady :: Connection -> IO Bool isConnection1RTTReady Connection{..} = atomically $ do

@@ -242,6 +242,7 @@     , connRecv          :: ~Recv -- ~ for testing     -- Manage     , connRecvQ         :: RecvQ+    , connRecvDatagramQ :: DatagramQ     , connSocket        :: IORef Socket     , genStatelessResetToken :: CID -> StatelessResetToken     , readers           :: IORef (Map Word64 (Weak ThreadId))@@ -337,11 +338,12 @@     -> IORef Socket     -> IORef PeerInfo     -> RecvQ+    -> DatagramQ     -> Send     -> Recv     -> (CID -> StatelessResetToken)     -> IO Connection-newConnection rl myParameters origVersionInfo myAuthCIDs peerAuthCIDs connDebugLog connQLog connHooks connSocket peerInfo connRecvQ ~connSend ~connRecv genStatelessResetToken = do+newConnection rl myParameters origVersionInfo myAuthCIDs peerAuthCIDs connDebugLog connQLog connHooks connSocket peerInfo connRecvQ connRecvDatagramQ ~connSend ~connRecv genStatelessResetToken = do     connState         <- newConnState rl     -- Manage     readers           <- newIORef Map.empty@@ -355,7 +357,7 @@     -- Peer     peerParameters    <- newIORef baseParameters     peerCIDDB         <- newTVarIO (newCIDDB peerCID)-    -- Queus+    -- Queues     inputQ            <- newTQueueIO     cryptoQ           <- newTQueueIO     outputQ           <- newTQueueIO@@ -429,12 +431,17 @@     -> IORef Socket     -> IORef PeerInfo     -> RecvQ+    -> DatagramQ     -> Send     -> Recv     -> (CID -> StatelessResetToken)     -> IO Connection clientConnection ClientConfig{..} verInfo myAuthCIDs peerAuthCIDs =-    newConnection Client ccParameters verInfo myAuthCIDs peerAuthCIDs+    newConnection Client ccParameters' verInfo myAuthCIDs peerAuthCIDs+  where+    ccParameters' = ccParameters+      { maxDatagramFrameSize = ccMaxDatagramFrameSize+      }  serverConnection     :: ServerConfig@@ -447,12 +454,17 @@     -> IORef Socket     -> IORef PeerInfo     -> RecvQ+    -> DatagramQ     -> Send     -> Recv     -> (CID -> StatelessResetToken)     -> IO Connection serverConnection ServerConfig{..} verInfo myAuthCIDs peerAuthCIDs =-    newConnection Server scParameters verInfo myAuthCIDs peerAuthCIDs+    newConnection Server scParameters' verInfo myAuthCIDs peerAuthCIDs+  where+    scParameters' = scParameters+      { maxDatagramFrameSize = scMaxDatagramFrameSize+      }  ---------------------------------------------------------------- @@ -471,6 +483,8 @@ ----------------------------------------------------------------  type SendStreamQ = TQueue TxStreamData++type DatagramQ = TQueue ByteString  data Shared = Shared     { sharedCloseSent :: IORef Bool

@@ -104,7 +104,13 @@ handshakeClient :: ClientConfig -> Connection -> AuthCIDs -> IO (IO ()) handshakeClient conf conn myAuthCIDs = do     qlogParamsSet conn (ccParameters conf, "local") -- fixme-    handshakeClient' conf conn myAuthCIDs <$> getVersion conn <*> newHndStateRef+    handshakeClient' conf' conn myAuthCIDs <$> getVersion conn <*> newHndStateRef+  where+    conf' = conf+      { ccParameters = (ccParameters conf)+        { maxDatagramFrameSize = ccMaxDatagramFrameSize conf+        }+      }  handshakeClient'     :: ClientConfig -> Connection -> AuthCIDs -> Version -> IORef HndState -> IO ()@@ -167,6 +173,7 @@     params =         (setCIDsToParameters myAuthCIDs $ scParameters conf)             { statelessResetToken = Just srt+            , maxDatagramFrameSize = scMaxDatagramFrameSize conf             }  handshakeServer'@@ -292,6 +299,15 @@                 _ -> sendCCVNError      setParams params = do+        when (isClient conn) $ do+            is0RTT <- isConnection0RTTReady conn+            when is0RTT $ do+                storedParams <- getPeerParameters conn+                let storedMaxDatagram = maxDatagramFrameSize storedParams+                    newMaxDatagram = maxDatagramFrameSize params+                when (storedMaxDatagram > 0 && newMaxDatagram < storedMaxDatagram) $+                    E.throwIO WrongDatagramSizeParameter+         setPeerParameters conn params         mapM_ (setPeerStatelessResetToken conn) $ statelessResetToken params         setTxMaxData conn $ initialMaxData params@@ -336,6 +352,7 @@ sendCCTLSError :: Connection -> TLS.TLSException -> IO () sendCCTLSError conn (TLS.HandshakeFailed (TLS.Error_Misc "WrongTransportParameter")) = closeConnection conn TransportParameterError "Transport parameter error" sendCCTLSError conn (TLS.HandshakeFailed (TLS.Error_Misc "WrongVersionInformation")) = closeConnection conn VersionNegotiationError "Version negotiation error"+sendCCTLSError conn (TLS.HandshakeFailed (TLS.Error_Misc "WrongDatagramSizeParameter")) = closeConnection conn ProtocolViolation "0-RTT datagram size violation" sendCCTLSError conn e = closeConnection conn err msg   where     tlserr = getErrorCause e

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.QUIC.IO where  import Control.Concurrent.STM@@ -8,6 +10,7 @@ import Network.QUIC.Connection import Network.QUIC.Connector import Network.QUIC.Imports+import Network.QUIC.Parameters import Network.QUIC.Stream import Network.QUIC.Types @@ -235,3 +238,41 @@         lvl <- getEncryptionLevel conn         let frame = StopSending sid aerr         putOutput conn $ OutControl lvl [frame]++-- | Sending a DATAGRAM frame to the peer.+--   If the datagram is larger than the peer's `max_datagram_frame_size`+--   an exception is thrown.+sendDatagram :: Connection -> ByteString -> IO ()+sendDatagram conn dat = do+    -- Determine the send level from connection readiness state rather than+    -- the encryptionLevel TVar, which is not set to RTT0Level during 0-RTT.+    ready1rtt <- isConnection1RTTReady conn+    lvl <- if ready1rtt+        then return RTT1Level+        else do+            ready0rtt <- isConnection0RTTReady conn+            if ready0rtt+                then return RTT0Level+                else E.throwIO $ ConnectionIsClosed "Cannot send DATAGRAM"+    limitBytes <- maxDatagramFrameSize <$> getPeerParameters conn+    when (limitBytes == 0) $+      E.throwIO $ ConnectionIsClosed "DATAGRAM not supported by peer"+    let frameOverhead = 1 + BS.length (encodeInt (fromIntegral $ BS.length dat))+    when (BS.length dat + frameOverhead > limitBytes) $+        E.throwIO $ ConnectionIsClosed "DATAGRAM size violation"+    let frame = Datagram False dat+    putOutput conn $ OutControl lvl [frame]++-- | Receiving a DATAGRAM frame.+--   This blocks until a DATAGRAM frame is received.+recvDatagram :: Connection -> IO ByteString+recvDatagram = atomically . recvDatagramSTM++-- | Receive all available DATAGRAM frames.+--   This function is non-blocking.+recvDatagramMany :: Connection -> IO [ByteString]+recvDatagramMany = atomically . flushTQueue . connRecvDatagramQ++-- | Receiving a DATAGRAM frame in STM.+recvDatagramSTM :: Connection -> STM ByteString+recvDatagramSTM = readTQueue . connRecvDatagramQ

@@ -4,6 +4,7 @@ import Network.QUIC.Connection import Network.QUIC.Types import Network.QUIC.Types.Info+import qualified Network.QUIC.Parameters as P import qualified Network.Socket as NS  ----------------------------------------------------------------@@ -17,6 +18,7 @@     peersa <- peerSockAddr <$> getPathInfo conn     mycid <- getMyCID conn     peercid <- getPeerCID conn+    peerdgsize <- P.maxDatagramFrameSize <$> getPeerParameters conn     c <- getCipher conn RTT1Level     mproto <- getApplicationProtocol conn     mode <- getTLSMode conn@@ -33,6 +35,7 @@             , remoteSockAddr = peersa             , localCID = mycid             , remoteCID = peercid+            , remoteDatagramFrameSize = peerdgsize             }  ----------------------------------------------------------------

@@ -19,7 +19,11 @@  encodeFrames :: [Frame] -> IO ByteString encodeFrames frames = withWriteBuffer 2048 $ \wbuf ->-    mapM_ (encodeFrame wbuf) frames+    let loop [] = return ()+        loop [Datagram _ dat] = encodeDatagramFinal wbuf dat+        loop [f] = encodeFrame wbuf f+        loop (f:fs) = encodeFrame wbuf f >> loop fs+    in loop frames  encodeFramesWithPadding     :: Buffer@@ -134,9 +138,19 @@     copyShortByteString wbuf reason encodeFrame wbuf HandshakeDone =     write8 wbuf 0x1e+encodeFrame wbuf (Datagram _ dat) = do+    write8 wbuf 0x31+    encodeInt' wbuf $ fromIntegral $ BS.length dat+    copyByteString wbuf dat encodeFrame wbuf (UnknownFrame typ) =     write8 wbuf $ fromIntegral typ +-- only valid when the datagram is the last frame and there's no padding+encodeDatagramFinal :: WriteBuffer -> ByteString -> IO ()+encodeDatagramFinal wbuf dat = do+    write8 wbuf 0x30+    copyByteString wbuf dat+ ----------------------------------------------------------------  decodeFramesBS :: ByteString -> IO (Maybe [Frame])@@ -190,6 +204,8 @@         0x1c -> decodeConnectionClose rbuf         0x1d -> decodeConnectionCloseApp rbuf         0x1e -> return HandshakeDone+        0x30 -> decodeDatagram rbuf False+        0x31 -> decodeDatagram rbuf True         x -> return $ UnknownFrame x  decodePadding :: ReadBuffer -> IO Frame@@ -360,3 +376,10 @@ decodePathResponse :: ReadBuffer -> IO Frame decodePathResponse rbuf =     PathResponse . PathData <$> extractShortByteString rbuf 8++decodeDatagram :: ReadBuffer -> Bool -> IO Frame+decodeDatagram rbuf hasLen = do+    len <- if hasLen+             then fromIntegral <$> decodeInt' rbuf+             else remainingSize rbuf+    Datagram hasLen <$> extractByteString rbuf len

@@ -70,6 +70,8 @@ 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@@ -98,6 +100,7 @@     , grease :: Maybe ByteString     , greaseQuicBit :: Bool     , versionInformation :: Maybe VersionInfo+    , maxDatagramFrameSize :: Int     }     deriving (Eq, Show) @@ -125,6 +128,7 @@         , grease = Nothing         , greaseQuicBit = False         , versionInformation = Nothing+        , maxDatagramFrameSize = 0         }  decInt :: ByteString -> Int@@ -205,6 +209,8 @@         x{greaseQuicBit = True}     update x (VersionInformation, v) =         x{versionInformation = toVersionInfo v}+    update x (MaxDatagramFrameSize, v) =+        x{maxDatagramFrameSize = decInt v}     update x _ = x  diff@@ -256,6 +262,7 @@         , diff p greaseQuicBit GreaseQuicBit (const "")         , diff p grease Grease fromJust         , diff p versionInformation VersionInformation fromVersionInfo+        , diff p maxDatagramFrameSize MaxDatagramFrameSize encInt         ]  encSRT :: Maybe StatelessResetToken -> ByteString@@ -289,7 +296,7 @@ -- | 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}+-- 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@@ -303,6 +310,7 @@         , initialMaxStreamsUni = 3         , activeConnectionIdLimit = 5         , greaseQuicBit = True+        , maxDatagramFrameSize = 0         }  data AuthCIDs = AuthCIDs

@@ -115,6 +115,7 @@ frameType ConnectionClose{} = "connection_close" frameType ConnectionCloseApp{} = "connection_close" frameType HandshakeDone{} = "handshake_done"+frameType Datagram{} = "datagram" frameType UnknownFrame{} = "unknown"  {-# INLINE frameExtra #-}@@ -169,6 +170,7 @@         <> toLogStr (Short.fromShort reason)         <> "\"" -- fixme frameExtra HandshakeDone{} = ""+frameExtra (Datagram _ dat) = ",\"length\":" <> sw (BS.length dat) frameExtra (UnknownFrame _Int) = ""  transportError :: TransportError -> LogStr

@@ -23,6 +23,7 @@ import Network.QUIC.Parameters import Network.QUIC.Qlog import Network.QUIC.Recovery+import Control.Concurrent.STM import Network.QUIC.Stream import Network.QUIC.Types as QUIC @@ -474,6 +475,16 @@     getConnectionInfo conn >>= onConnectionEstablished (connHooks conn)     -- to receive NewSessionTicket     fire conn (Microseconds 1000000) $ killHandshaker conn lvl+processFrame conn lvl (Datagram hasLen dat) = do+    when (lvl /= RTT0Level && lvl /= RTT1Level) $+        closeConnection conn ProtocolViolation "DATAGRAM in Initial or Handshake"+    let limitBytes = maxDatagramFrameSize (getMyParameters conn)+    let lenSize = if hasLen then BS.length (encodeInt . fromIntegral $ BS.length dat) else 0+    when (limitBytes == 0) $+        closeConnection conn ProtocolViolation "DATAGRAM not supported"+    when (1 + lenSize + BS.length dat > limitBytes) $+        closeConnection conn ProtocolViolation "DATAGRAM size violation"+    atomically $ writeTQueue (connRecvDatagramQ conn) dat processFrame conn _ _ = closeConnection conn ProtocolViolation "Frame is not allowed"  -- Return value indicates duplication.

@@ -340,6 +340,7 @@     let r = MaxData newMax     rs <- adjustForRetransmit conn xs     return (r : rs)+adjustForRetransmit conn (Datagram{} : xs) = adjustForRetransmit conn xs adjustForRetransmit conn (x : xs) = do     rs <- adjustForRetransmit conn xs     return (x : rs)

@@ -12,6 +12,7 @@     scALPN,     scRequireRetry,     scUse0RTT,+    scMaxDatagramFrameSize,     scCiphers,     scGroups,     scVersions,

@@ -160,6 +160,7 @@     (qLog, qclean) <- dirQLogger scQLog accTime ocid "server"     (debugLog, dclean) <- dirDebugLogger scDebugLog ocid     debugLog $ "Original CID: " <> bhow ocid+    connRecvDatagramQ <- newTQueueIO     conn <-         serverConnection             conf@@ -172,6 +173,7 @@             sref             piref             accRecvQ+            connRecvDatagramQ             send             recv             (genStatelessReset dispatch)

@@ -31,6 +31,7 @@     = MustNotReached     | ExitConnection     | WrongTransportParameter+    | WrongDatagramSizeParameter     | WrongVersionInformation     | BreakForever     deriving (Eq, Show)

@@ -40,6 +40,7 @@     | ConnectionClose TransportError FrameType ReasonPhrase     | ConnectionCloseApp ApplicationProtocolError ReasonPhrase     | HandshakeDone+    | Datagram Bool ByteString     | UnknownFrame Int     deriving (Eq, Show) 

@@ -24,6 +24,7 @@     , remoteSockAddr :: NS.SockAddr     , localCID :: CID     , remoteCID :: CID+    , remoteDatagramFrameSize :: Int     }  instance Show ConnectionInfo where@@ -51,4 +52,7 @@             ++ "\n"             ++ "Remote SockAddr: "             ++ show remoteSockAddr+            ++ "\n"+            ++ "Remote DatagramFrameSize: "+            ++ show remoteDatagramFrameSize             ++ if retry then "\nQUIC retry" else ""

@@ -26,6 +26,7 @@     , resumptionInitialMaxStreamDataUni :: Int     , resumptionInitialMaxStreamsBidi :: Int     , resumptionInitialMaxStreamsUni :: Int+    , resumptionMaxDatagramFrameSize :: Int     }     deriving (Eq, Show, Generic) @@ -45,6 +46,7 @@         , resumptionInitialMaxStreamDataUni = 0         , resumptionInitialMaxStreamsBidi = 0         , resumptionInitialMaxStreamsUni = 0+        , resumptionMaxDatagramFrameSize = 0         }  -- | Is 0RTT possible?

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               quic-version:            0.3.1+version:            0.3.2 license:            BSD3 license-file:       LICENSE maintainer:         kazu@iij.ad.jp@@ -237,6 +237,7 @@     hs-source-dirs:     test     other-modules:         Config+        DatagramSpec         ErrorSpec         FrameSpec         HandshakeSpec@@ -262,6 +263,7 @@         network >=3.2.2,         quic,         ram,+        stm,         tls,         unix-time 

@@ -150,7 +150,7 @@   where     hints =         defaultHints-            { addrSocketType = Datagram+            { addrSocketType = Network.Socket.Datagram             , addrFlags = [AI_NUMERICHOST]             , addrFamily = AF_INET             }

@@ -0,0 +1,314 @@+{-# LANGUAGE OverloadedStrings #-}++module DatagramSpec where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import Data.ByteString ()+import qualified Data.ByteString as BS+import Test.Hspec++import Network.QUIC+import Network.QUIC.Client as C+import Network.QUIC.Internal hiding (RTT0)+import Network.QUIC.Server as S+import Network.TLS (HandshakeMode13 (..))++import Config++spec :: Spec+spec = do+    sc0' <- runIO makeTestServerConfig+    let sc0 = sc0'+    describe "Datagram MUST requirements" $ do+        -- "An endpoint that receives a DATAGRAM frame when it has not indicated support via the transport parameter MUST terminate the connection with an error of type PROTOCOL_VIOLATION."+        it "Server MUST send PROTOCOL_VIOLATION if DATAGRAM received without negotiation" $ do+            let cc = testClientConfig { ccHooks = (ccHooks testClientConfig) { onPlainCreated = injectDatagram1RTT } }+            testServerExpectError cc sc0 isProtocolViolationReceived++        -- "An endpoint that receives a DATAGRAM frame when it has not indicated support via the transport parameter MUST terminate the connection with an error of type PROTOCOL_VIOLATION."+        it "Client MUST send PROTOCOL_VIOLATION if DATAGRAM received without negotiation" $ do+            let sc = sc0 { scHooks = (scHooks sc0) { onPlainCreated = injectDatagram1RTT } }+            testClientExpectError testClientConfig sc isProtocolViolationSent++        -- "Similarly, an endpoint that receives a DATAGRAM frame that is larger than the value it sent in its max_datagram_frame_size transport parameter MUST terminate the connection with an error of type PROTOCOL_VIOLATION."+        it "Rejects DATAGRAM larger than max_datagram_frame_size" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 10 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 10+                                          , ccHooks = (ccHooks testClientConfig) { onPlainCreated = injectLargeDatagram } }+            testServerExpectError ccDtgm scDtgm isProtocolViolationReceived++        -- "Like STREAM frames, DATAGRAM frames contain application data and MUST be protected with either 0-RTT or 1-RTT keys."+        it "MUST send PROTOCOL_VIOLATION if DATAGRAM in Initial or Handshake" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024+                                          , ccHooks = (ccHooks testClientConfig) { onPlainCreated = injectDatagramInitial } }+            testServerExpectError ccDtgm scDtgm isProtocolViolationReceived++        -- "If a client stores the value of the max_datagram_frame_size transport parameter with their 0-RTT state, they MUST validate that the new value of the max_datagram_frame_size transport parameter sent by the server in the handshake is greater than or equal to the stored value; if not, the client MUST terminate the connection with error PROTOCOL_VIOLATION."+        it "Client MUST reject 0-RTT downgrade server parameters" $ do+            let scInit = sc0 { scMaxDatagramFrameSize = 1024 }+                scDowngrade = sc0 { scMaxDatagramFrameSize = 500 }+                cc0RTT = testClientConfig { ccMaxDatagramFrameSize = 1024 }+            testDatagram0RTTDowngrade cc0RTT scInit scDowngrade++        -- "An endpoint MUST NOT send DATAGRAM frames until it has received the max_datagram_frame_size transport parameter with a non-zero value"+        it "Endpoint MUST NOT send DATAGRAM if not negotiated" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 0 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 0 }+            mvar <- newEmptyMVar+            smgr <- newSessionManager+            let sc' = scDtgm { scSessionManager = smgr+                             , scHooks = (scHooks scDtgm) { onServerReady = putMVar mvar () } }+            E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run sc' (\conn -> waitEstablished conn >> threadDelay 2000000)) killThread $ \_ -> do+                takeMVar mvar+                let isNoSupport (ConnectionIsClosed err) = err == "DATAGRAM not supported by peer"+                    isNoSupport _ = False+                C.run ccDtgm (\conn -> do+                    waitEstablished conn+                    sendDatagram conn "data") `shouldThrow` isNoSupport++        -- "An endpoint MUST NOT send DATAGRAM frames that are larger than the max_datagram_frame_size value it has received from its peer."+        it "Endpoint MUST NOT send DATAGRAM larger than peer's max_datagram_frame_size" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 10 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 10 }+            mvar <- newEmptyMVar+            smgr <- newSessionManager+            let sc' = scDtgm { scSessionManager = smgr+                             , scHooks = (scHooks scDtgm) { onServerReady = putMVar mvar () } }+            E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run sc' (\conn -> waitEstablished conn >> threadDelay 2000000)) killThread $ \_ -> do+                takeMVar mvar+                let isSizeViolation (ConnectionIsClosed err) = err == "DATAGRAM size violation"+                    isSizeViolation _ = False+                C.run ccDtgm (\conn -> do+                    waitEstablished conn+                    sendDatagram conn (BS.replicate 20 0x41)) `shouldThrow` isSizeViolation++        -- "When servers decide to accept 0-RTT data, they MUST send a max_datagram_frame_size transport parameter greater than or equal to the value they sent to the client..."+        it "Server MUST NOT downgrade max_datagram_frame_size on 0-RTT" $ do+            let scInit = sc0 { scMaxDatagramFrameSize = 1024 }+                scDowngrade = sc0 { scMaxDatagramFrameSize = 500 }+                cc0RTT = testClientConfig { ccMaxDatagramFrameSize = 1024 }++            mvar <- newEmptyMVar+            smgr <- newSessionManager++            -- Phase 1+            let scInit' = scInit { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks scInit) { onServerReady = putMVar mvar () } }+            res <- E.bracket (forkIO $ S.run scInit' (\c -> waitEstablished c >> threadDelay 100000)) killThread $ \_ -> do+                takeMVar mvar+                C.run cc0RTT $ \conn -> do+                    waitEstablished conn+                    threadDelay 50000+                    getResumptionInfo conn++            -- Phase 2+            let cc2 = cc0RTT { ccResumption = res, ccUse0RTT = True }+            mvar2 <- newEmptyMVar+            let scDowngrade' = scDowngrade { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks scDowngrade) { onServerReady = putMVar mvar2 () } }++            E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run scDowngrade' (\conn -> do+                        waitEstablished conn+                        threadDelay 2000000)) killThread $ \_ -> do+                takeMVar mvar2+                C.run cc2 (\_ -> threadDelay 2000000) `shouldThrow` isWrongDatagramSize++        -- "The sender MUST either delay sending the frame until the controller allows it or drop the frame without sending it"+        it "Sender MUST apply congestion control to DATAGRAM frames" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024 }+            mvar <- newEmptyMVar+            smgr <- newSessionManager+            let sc' = scDtgm { scSessionManager = smgr+                             , scHooks = (scHooks scDtgm) { onServerReady = putMVar mvar () } }+            E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run sc' (\conn -> waitEstablished conn >> threadDelay 2000000)) killThread $ \_ -> do+                takeMVar mvar+                C.run ccDtgm $ \conn -> do+                    waitEstablished conn+                    replicateM_ 100 $ do+                        sendDatagram conn (BS.replicate 50 0x41)+                        threadDelay 500++    describe "Datagram SHOULD requirements" $ do+        -- "This frame SHOULD be sent as soon as possible... and MAY be coalesced with other frames."+        it "Can send and receive DATAGRAM in 1-RTT" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024 }+            testDatagram1RTT ccDtgm scDtgm True++        -- Zero-length datagrams are explicitly permitted by the spec (Section 4)+        it "Can handle zero-length DATAGRAM" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024+                                          , ccHooks = (ccHooks testClientConfig) { onPlainCreated = injectZeroLengthDatagram } }+            testDatagram1RTT ccDtgm scDtgm False++        -- "When clients use 0-RTT, they MAY store the value of the server's max_datagram_frame_size transport parameter. Doing so allows the client to send DATAGRAM frames in 0-RTT packets."+        it "Can utilize 0-RTT DATAGRAM successfully" $ do+            let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 }+                ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024 }+            testDatagram0RTT ccDtgm scDtgm++injectDatagram1RTT :: EncryptionLevel -> Plain -> Plain+injectDatagram1RTT lvl plain+    | lvl == RTT1Level = plain { plainFrames = Datagram False "hello" : plainFrames plain }+    | otherwise = plain++injectLargeDatagram :: EncryptionLevel -> Plain -> Plain+injectLargeDatagram lvl plain+    | lvl == RTT1Level = plain { plainFrames = Datagram False (BS.replicate 20 0x41) : plainFrames plain }+    | otherwise = plain++injectDatagramInitial :: EncryptionLevel -> Plain -> Plain+injectDatagramInitial lvl plain+    | lvl == InitialLevel = plain { plainFrames = Datagram False "hello" : plainFrames plain }+    | otherwise = plain++injectZeroLengthDatagram :: EncryptionLevel -> Plain -> Plain+injectZeroLengthDatagram lvl plain+    | lvl == RTT1Level = plain { plainFrames = Datagram False "" : plainFrames plain }+    | otherwise = plain++isProtocolViolationSent :: QUICException -> Bool+isProtocolViolationSent (TransportErrorIsSent ProtocolViolation _) = True+isProtocolViolationSent _ = False++isProtocolViolationReceived :: QUICException -> Bool+isProtocolViolationReceived (TransportErrorIsReceived ProtocolViolation _) = True+isProtocolViolationReceived _ = False++isWrongDatagramSize :: QUICException -> Bool+isWrongDatagramSize (TransportErrorIsSent ProtocolViolation _) = True+isWrongDatagramSize (TransportErrorIsReceived ProtocolViolation _) = True+isWrongDatagramSize _ = False++-- | Server detects the error and sends ConnectionClose; client receives it.+testServerExpectError :: ClientConfig -> ServerConfig -> (QUICException -> Bool) -> IO ()+testServerExpectError cc sc selector = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager+    let sc' = sc { scSessionManager = smgr+                 , scHooks = (scHooks sc) { onServerReady = putMVar mvar () } }+    E.bracket (forkIO $ server sc') killThread $ \_ -> client mvar+  where+    client mvar = do+        () <- takeMVar mvar+        C.run cc (\conn -> do+            wait1RTTReady conn+            threadDelay 2000000) `shouldThrow` selector+    server sc' =+        E.handle (\(E.SomeException _) -> return ()) $ S.run sc' $ \conn -> do+            wait1RTTReady conn+            threadDelay 2000000++-- | Client detects the error and sends ConnectionClose itself.+testClientExpectError :: ClientConfig -> ServerConfig -> (QUICException -> Bool) -> IO ()+testClientExpectError cc sc selector = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager+    let sc' = sc { scSessionManager = smgr+                 , scHooks = (scHooks sc) { onServerReady = putMVar mvar () } }+    E.bracket (forkIO $ server sc') killThread $ \_ -> client mvar+  where+    client mvar = do+        () <- takeMVar mvar+        C.run cc (\conn -> do+            wait1RTTReady conn+            threadDelay 2000000) `shouldThrow` selector+    server sc' =+        E.handle (\(E.SomeException _) -> return ()) $ S.run sc' $ \conn -> do+            wait1RTTReady conn+            threadDelay 2000000++testDatagram1RTT :: ClientConfig -> ServerConfig -> Bool -> IO ()+testDatagram1RTT cc sc expectServerData = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager+    let sc' = sc { scSessionManager = smgr+                 , scHooks = (scHooks sc) { onServerReady = putMVar mvar () } }+    E.bracket (forkIO $ server sc') killThread $ \_ -> client mvar+  where+    client mvar = do+        () <- takeMVar mvar+        C.run cc $ \conn -> do+            waitEstablished conn+            sendDatagram conn "client_data"+            when expectServerData $ do+                recv <- recvDatagram conn+                recv `shouldBe` "server_data"+    server sc' = do+        S.run sc' $ \conn -> do+            waitEstablished conn+            recv <- recvDatagram conn+            when (BS.length recv == 0 || recv == "hello") $ void (recvDatagram conn)+            when expectServerData $ sendDatagram conn "server_data"+++testDatagram0RTT :: ClientConfig -> ServerConfig -> IO ()+testDatagram0RTT cc1 sc1 = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager++    -- Phase 1: initial connection to get resumption info+    let scInit = sc1 { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks sc1) { onServerReady = putMVar mvar () } }++    res <- E.bracket (forkIO $ S.run scInit (\c -> waitEstablished c >> threadDelay 100000)) killThread $ \_ -> do+        takeMVar mvar+        C.run cc1 $ \conn -> do+            waitEstablished conn+            threadDelay 50000+            getResumptionInfo conn++    -- Phase 2: 0-RTT connection with datagram+    let cc2 = cc1 { ccResumption = res, ccUse0RTT = True }++    mvar2 <- newEmptyMVar+    let sc0RTT = scInit { scHooks = (scHooks sc1) { onServerReady = putMVar mvar2 () } }++    E.bracket (forkIO $ server0RTT sc0RTT) killThread $ \_ -> client0RTT cc2 mvar2+  where+    client0RTT cc2 mvar2 = do+        () <- takeMVar mvar2+        C.run cc2 $ \conn -> do+            sendDatagram conn "0rtt_client_data"+            waitEstablished conn+            threadDelay 50000+    server0RTT sc = S.run sc $ \conn -> do+        waitEstablished conn+        info <- getConnectionInfo conn+        when (handshakeMode info == RTT0) $ do+            recv <- recvDatagram conn+            recv `shouldBe` "0rtt_client_data"++testDatagram0RTTDowngrade :: ClientConfig -> ServerConfig -> ServerConfig -> IO ()+testDatagram0RTTDowngrade cc1 scInit scDowngrade = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager++    -- Phase 1: initial connection to get resumption info+    let scInit' = scInit { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks scInit) { onServerReady = putMVar mvar () } }++    res <- E.bracket (forkIO $ S.run scInit' (\c -> waitEstablished c >> threadDelay 100000)) killThread $ \_ -> do+        takeMVar mvar+        C.run cc1 $ \conn -> do+            waitEstablished conn+            threadDelay 50000+            getResumptionInfo conn++    -- Phase 2: reconnect with downgraded server params; client should detect and reject+    let cc2 = cc1 { ccResumption = res, ccUse0RTT = True }++    mvar2 <- newEmptyMVar+    let scDowngrade' = scDowngrade { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks scDowngrade) { onServerReady = putMVar mvar2 () } }++    E.bracket (forkIO $ server scDowngrade') killThread $ \_ ->+        client mvar2 cc2+  where+    server sc =+        E.handle (\(E.SomeException _) -> return ()) $ S.run sc $ \conn -> do+            waitEstablished conn+            threadDelay 2000000+    client mvar2 cc2 = do+        () <- takeMVar mvar2+        C.run cc2 (\_ -> threadDelay 2000000) `shouldThrow` isWrongDatagramSize

@@ -10,6 +10,7 @@ import Test.Hspec  import Network.QUIC.Internal+import Control.Concurrent.STM  import Config @@ -54,6 +55,7 @@     let ver = v         verInfo = VersionInfo ver [ver]     genSRT <- makeGenStatelessReset+    dq <- newTQueueIO     ----     clientConn <-         clientConnection@@ -67,8 +69,9 @@             sref             piref             q-            undefined-            undefined+            dq+            (\_ _ -> return ())+            (return undefined)             genSRT     initializeCoder clientConn InitialLevel $ initialSecrets ver serverCID     serverConn <-@@ -83,8 +86,9 @@             sref             piref -- dummy             q-            undefined-            undefined+            dq+            (\_ _ -> return ())+            (return undefined)             genSRT     initializeCoder serverConn InitialLevel $ initialSecrets ver serverCID     ----