diff --git a/HTTP3Error.hs b/HTTP3Error.hs new file mode 100644 --- /dev/null +++ b/HTTP3Error.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HTTP3Error ( + h3ErrorSpec, +) where + +import Control.Concurrent +import Data.ByteString () +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Types +import qualified Network.HTTP3.Client as H3 +import Network.HTTP3.Internal +import Network.QPACK.Internal +import Network.QUIC +import Network.QUIC.Client +import Network.QUIC.Internal hiding (timeout) +import Test.Hspec +import qualified UnliftIO.Exception as E +import UnliftIO.Timeout + +---------------------------------------------------------------- + +type Millisecond = Int + +runC + :: ClientConfig -> H3.ClientConfig -> H3.Config -> Millisecond -> IO (Maybe ()) +runC qcc cconf conf ms = timeout us $ run qcc $ \conn -> do + info <- getConnectionInfo conn + case alpn info of + Just proto | "hq" `BS.isPrefixOf` proto -> do + waitEstablished conn + putStrLn $ + "Warning: " + ++ C8.unpack proto + ++ " is negotiated. Skipping this test. Use \"h3spec -s HTTP/3\" next time." + E.throwIO $ ApplicationProtocolErrorIsReceived H3InternalError "" + _ -> H3.run conn cconf conf client + where + us = ms * 1000 + client :: H3.Client () + client sendRequest _aux = do + let req = H3.requestNoBody methodGet "/" [] + ret <- sendRequest req $ \_rsp -> return () + threadDelay 100000 + return ret + +h3ErrorSpec :: ClientConfig -> H3.ClientConfig -> Millisecond -> SpecWith a +h3ErrorSpec qcc cconf ms = do + conf0 <- runIO H3.allocSimpleConfig + describe "HTTP/3 servers" $ do + it + "MUST send H3_FRAME_UNEXPECTED if DATA is received before HEADERS [HTTP/3 4.1]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated requestIllegalData + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected] + it "MUST send H3_MESSAGE_ERROR if a pseudo-header is duplicated [HTTP/3 4.1.1]" $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader3 + qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "") + runC qcc' cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3MessageError] + it + "MUST send H3_MESSAGE_ERROR if mandatory pseudo-header fields are absent [HTTP/3 4.1.3]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader0 + qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "") + runC qcc' cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3MessageError] + it + "MUST send H3_MESSAGE_ERROR if prohibited pseudo-header fields are present[HTTP/3 4.1.3]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader1 + qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "") + runC qcc' cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3MessageError] + it + "MUST send H3_MESSAGE_ERROR if pseudo-header fields exist after fields [HTTP/3 4.1.3]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader2 + qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "") + runC qcc' cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3MessageError] + it + "MUST send H3_MISSING_SETTINGS if the first control frame is not SETTINGS [HTTP/3 6.2.1]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated startWithNonSettings + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3MissingSettings] + it + "MUST send H3_FRAME_UNEXPECTED if a DATA frame is received on a control stream [HTTP/3 7.2.1]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated controlData + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected] + it + "MUST send H3_FRAME_UNEXPECTED if a HEADERS frame is received on a control stream [HTTP/3 7.2.2]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated controlHeaders + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected] + it + "MUST send H3_FRAME_UNEXPECTED if a second SETTINGS frame is received [HTTP/3 7.2.4]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated doubleSettings + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected] + {- this is MAY + it "MUST send H3_SETTINGS_ERROR if duplicate setting identifiers exist [HTTP/3 7.2.4]" $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated illegalSettings0 + runC qcc cconf conf ms `shouldThrow` applicationProtocolErrorsIn [H3SettingsError] + -} + it + "MUST send H3_SETTINGS_ERROR if HTTP/2 settings are included [HTTP/3 7.2.4.1]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlFrameCreated illegalSettings1 + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3SettingsError] + it + "MUST send H3_FRAME_UNEXPECTED if CANCEL_PUSH is received in a request stream [HTTP/3 7.2.5]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated requestCancelPush + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected] + it + "MUST send QPACK_DECOMPRESSION_FAILED if an invalid static table index exits in a field line representation [QPACK 3.1]" + $ \_ -> do + let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader4 + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [QpackDecompressionFailed] + it + "MUST send QPACK_ENCODER_STREAM_ERROR if a new dynamic table capacity value exceeds the limit [QPACK 4.1.3]" + $ \_ -> do + let conf = addHook conf0 $ setOnEncoderStreamCreated largeTableCapacity + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [QpackEncoderStreamError] + it + "MUST send H3_CLOSED_CRITICAL_STREAM if a control stream is closed [QPACK 4.2]" + $ \_ -> do + let conf = addHook conf0 $ setOnControlStreamCreated closeStream + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream] + it + "MUST send QPACK_DECODER_STREAM_ERROR if Insert Count Increment is 0 [QPACK 4.4.3]" + $ \_ -> do + let conf = addHook conf0 $ setOnDecoderStreamCreated zeroInsertCountIncrement + runC qcc cconf conf ms + `shouldThrow` applicationProtocolErrorsIn [QpackDecoderStreamError] + +---------------------------------------------------------------- + +addHook :: H3.Config -> (H3.Hooks -> H3.Hooks) -> H3.Config +addHook conf modify = conf' + where + hooks = H3.confHooks conf + hooks' = modify hooks + conf' = conf{H3.confHooks = hooks'} + +setOnControlFrameCreated :: ([H3Frame] -> [H3Frame]) -> H3.Hooks -> H3.Hooks +setOnControlFrameCreated f hooks = hooks{H3.onControlFrameCreated = f} + +setOnHeadersFrameCreated :: ([H3Frame] -> [H3Frame]) -> H3.Hooks -> H3.Hooks +setOnHeadersFrameCreated f hooks = hooks{H3.onHeadersFrameCreated = f} + +setOnControlStreamCreated :: (Stream -> IO ()) -> H3.Hooks -> H3.Hooks +setOnControlStreamCreated f hooks = hooks{H3.onControlStreamCreated = f} + +setOnEncoderStreamCreated :: (Stream -> IO ()) -> H3.Hooks -> H3.Hooks +setOnEncoderStreamCreated f hooks = hooks{H3.onEncoderStreamCreated = f} + +setOnDecoderStreamCreated :: (Stream -> IO ()) -> H3.Hooks -> H3.Hooks +setOnDecoderStreamCreated f hooks = hooks{H3.onDecoderStreamCreated = f} + +---------------------------------------------------------------- + +startWithNonSettings :: [H3Frame] -> [H3Frame] +startWithNonSettings fs = H3Frame H3FrameMaxPushId "\x01" : fs + +doubleSettings :: [H3Frame] -> [H3Frame] +doubleSettings fs = fs ++ [H3Frame H3FrameSettings ""] + +controlData :: [H3Frame] -> [H3Frame] +controlData fs = fs ++ [H3Frame H3FrameData ""] + +controlHeaders :: [H3Frame] -> [H3Frame] +controlHeaders fs = fs ++ [H3Frame H3FrameHeaders ""] + +requestCancelPush :: [H3Frame] -> [H3Frame] +requestCancelPush fs = H3Frame H3FrameCancelPush "" : fs + +requestIllegalData :: [H3Frame] -> [H3Frame] +requestIllegalData fs = H3Frame H3FrameData "" : fs + +-- [(":method","GET") +-- ,(":scheme","https") +-- ,(":path","/") +-- ] -- the absence of mandatory pseudo-header fields +illegalHeader0 :: [H3Frame] -> [H3Frame] +illegalHeader0 _ = [H3Frame H3FrameHeaders "\x00\x00\xd1\xd7\xc1"] + +-- [(":method","GET") +-- ,(":scheme","https") +-- ,(":autority","127.0.0.1") +-- ,(":path","/") +-- ,(":foo","bar") -- the presence of prohibited fields or pseudo-header fields, +-- ] +illegalHeader1 :: [H3Frame] -> [H3Frame] +illegalHeader1 _ = + [ H3Frame + H3FrameHeaders + "\x00\x00\xd1\xd7\x27\x02\x3a\x61\x75\x74\x6f\x72\x69\x74\x79\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\x24\x3a\x66\x6f\x6f\x03\x62\x61\x72" + ] + +-- [(":method","GET") +-- ,(":scheme","https") +-- ,(":autority","127.0.0.1") +-- ,("foo","bar") +-- ,(":path","/") -- pseudo-header fields after fields +-- ] +illegalHeader2 :: [H3Frame] -> [H3Frame] +illegalHeader2 _ = + [ H3Frame + H3FrameHeaders + "\x00\x00\xd1\xd7\x27\x02\x3a\x61\x75\x74\x6f\x72\x69\x74\x79\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\x23\x66\x6f\x6f\x03\x62\x61\x72\xc1" + ] + +-- [(":method","GET") +-- ,(":scheme","https") +-- ,(":authority","127.0.0.1") +-- ,(":path","/") +-- ,(":method","GET")] +illegalHeader3 :: [H3Frame] -> [H3Frame] +illegalHeader3 _ = + [ H3Frame + H3FrameHeaders + "\x00\x00\xd1\xd7\x50\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\xd1" + ] + +-- [(":method","GET") +-- ,(":scheme","https") +-- ,(":authority","127.0.0.1") +-- ,(":path","/")] ++ static index 99 +illegalHeader4 :: [H3Frame] -> [H3Frame] +illegalHeader4 _ = + [ H3Frame + H3FrameHeaders + "\x00\x00\xd1\xd7\x50\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\xff\x24" + ] + +{- +-- [(SettingsQpackBlockedStreams,100) +-- ,(SettingsQpackMaxTableCapacity,4096) +-- ,(SettingsMaxFieldSectionSize,32768) +-- ,(SettingsQpackBlockedStreams,100)] -- duplicated +illegalSettings0 :: [H3Frame]-> [H3Frame] +illegalSettings0 _ = [H3Frame H3FrameSettings "\x07\x40\x64\x01\x50\x00\x06\x80\x00\x80\x00\x07\x40\x64"] +-} + +-- [(SettingsQpackBlockedStreams,100) +-- ,(H3SettingsKey 0x2,200) -- HTTP/2 Settings +-- ,(SettingsQpackMaxTableCapacity,4096) +-- ,(SettingsMaxFieldSectionSize,32768)] +illegalSettings1 :: [H3Frame] -> [H3Frame] +illegalSettings1 _ = + [ H3Frame + H3FrameSettings + "\x07\x40\x64\x02\x40\xc8\x01\x50\x00\x06\x80\x00\x80\x00" + ] + +---------------------------------------------------------------- + +-- SetDynamicTableCapacity 10000000000 +largeTableCapacity :: Stream -> IO () +largeTableCapacity strm = sendStream strm "\x3f\xe1\xc7\xaf\xa0\x25" + +-- InsertCountIncrement 0 +zeroInsertCountIncrement :: Stream -> IO () +zeroInsertCountIncrement strm = sendStream strm "\x00" + +---------------------------------------------------------------- + +addQUICHook :: ClientConfig -> (Hooks -> Hooks) -> ClientConfig +addQUICHook cc modify = cc' + where + cc' = cc{ccHooks = modify $ ccHooks cc} + +setOnResetStreamReceived + :: (Stream -> ApplicationProtocolError -> IO ()) -> Hooks -> Hooks +setOnResetStreamReceived f hooks = hooks{onResetStreamReceived = f} + +---------------------------------------------------------------- + +applicationProtocolError :: QUICException -> Bool +applicationProtocolError (ApplicationProtocolErrorIsReceived ae _) = ae `elem` [H3GeneralProtocolError, H3InternalError] +applicationProtocolError _ = False + +applicationProtocolErrorsIn + :: [ApplicationProtocolError] -> QUICException -> Bool +applicationProtocolErrorsIn aes qe@(ApplicationProtocolErrorIsReceived ae _) = (ae `elem` aes) || applicationProtocolError qe +applicationProtocolErrorsIn _ _ = False diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2020, IIJ Innovation Institute Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/TransportError.hs b/TransportError.hs new file mode 100644 --- /dev/null +++ b/TransportError.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TransportError ( + transportErrorSpec, +) where + +import Control.Monad +import Data.ByteString () +import qualified Data.ByteString as BS +import qualified Network.TLS as TLS +import Network.TLS.QUIC (ExtensionID (..), ExtensionRaw (..)) +import Test.Hspec +import UnliftIO.Concurrent +import UnliftIO.Timeout + +import Network.QUIC.Client +import Network.QUIC.Internal hiding (timeout) + +---------------------------------------------------------------- + +type Millisecond = Int + +runC :: ClientConfig -> Millisecond -> (Connection -> IO a) -> IO (Maybe a) +runC cc ms body = timeout us $ run cc body' + where + us = ms * 1000 + body' conn = do + waitEstablished conn + threadDelay 100000 + body conn + +runCnoOp :: ClientConfig -> Millisecond -> IO (Maybe ()) +runCnoOp cc ms = timeout us $ run cc body' + where + us = ms * 1000 + body' conn = do + waitEstablished conn + threadDelay us + +transportErrorSpec :: ClientConfig -> Millisecond -> SpecWith a +transportErrorSpec cc0 ms = do + describe "QUIC servers" $ do + it + "MUST send FLOW_CONTROL_ERROR if a STREAM frame with a large offset is received [Transport 4.1]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated largeOffset + runCnoOp cc ms `shouldThrow` transportErrorsIn [FlowControlError] + it "MUST send STREAM_LIMIT_ERROR if a stream ID exceeding the limit" $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated largeStreamId + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamLimitError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if initial_source_connection_id is missing [Transport 7.3]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated dropInitialSourceConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if original_destination_connection_id is received [Transport 18.2]" + $ \_ -> do + let cc = + addHook cc0 $ setOnTransportParametersCreated setOriginalDestinationConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if preferred_address, is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setPreferredAddress + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if retry_source_connection_id is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setRetrySourceConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if stateless_reset_token is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setStatelessResetToken + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if max_udp_payload_size < 1200 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setMaxUdpPayloadSize + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if ack_delay_exponen > 20 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setAckDelayExponent + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if max_ack_delay >= 2^14 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setMaxAckDelay + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send FRAME_ENCODING_ERROR if a frame of unknown type is received [Transport 12.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated unknownFrame + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it "MUST send PROTOCOL_VIOLATION on no frames [Transport 12.4]" $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated noFrames + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send PROTOCOL_VIOLATION if reserved bits in Handshake are non-zero [Transport 17.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ rrBits HandshakeLevel + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send PROTOCOL_VIOLATION if PATH_CHALLENGE in Handshake is received [Transport 17.2.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated handshakePathChallenge + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send PROTOCOL_VIOLATION if reserved bits in Short are non-zero [Transport 17.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ rrBits RTT1Level + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send STREAM_STATE_ERROR if RESET_STREAM is received for a send-only stream [Transport 19.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated resetStrm + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if STOP_SENDING is received for a non-existing stream [Transport 19.5]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated stopSending + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it "MUST send PROTOCOL_VIOLATION if NEW_TOKEN is received [Transport 19.7]" $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated newToken + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a locally-initiated stream that has not yet been created [Transport 19.8]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated localInitiatedNotCreatedYet + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a send-only stream [Transport 19.8]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated sendOnlyStream + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a stream that has not yet been created [Transport 19.10]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreamData + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a receive-only stream [Transport 19.10]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreamData2 + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send FRAME_ENCODING_ERROR if invalid MAX_STREAMS is received [Transport 19.11]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreams' + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send STREAM_LIMIT_ERROR or FRAME_ENCODING_ERROR if invalid STREAMS_BLOCKED is received [Transport 19.14]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated streamsBlocked + runCnoOp cc ms + `shouldThrow` transportErrorsIn [FrameEncodingError, StreamLimitError] + it + "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with invalid Retire_Prior_To is received [Transport 19.15]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidLargeRPT + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with 0-byte CID is received [Transport 19.15]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidZeroCID + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send PROTOCOL_VIOLATION if HANDSHAKE_DONE is received [Transport 19.20]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated handshakeDone + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send unexpected_message TLS alert if KeyUpdate in Handshake is received [TLS 6]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it + "MUST send unexpected_message TLS alert if KeyUpdate in 1-RTT is received [TLS 6]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate2 + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it + "MUST send no_application_protocol TLS alert if no application protocols are supported [TLS 8.1]" + $ \_ -> do + let cc = cc0{ccALPN = \_ -> return $ Just ["dummy"]} + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.NoApplicationProtocol] + it + "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSExtensionCreated (const []) + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] + it + "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" + $ \_ -> do + let f [ExtensionRaw _ v] = [ExtensionRaw (ExtensionID 0xffa5) v] + f _ = error "f" + cc = addHook cc0 $ setOnTLSExtensionCreated f + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] + it + "MUST send unexpected_message TLS alert if EndOfEarlyData is received [TLS 8.3]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoEndOfEarlyData + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it "MUST send PROTOCOL_VIOLATION if CRYPTO in 0-RTT is received [TLS 8.3]" $ \_ -> do + mres <- runC cc0 ms getResumptionInfo + case mres of + Just res + | is0RTTPossible res -> do + let cc1 = addHook cc0 $ setOnTLSHandshakeCreated crypto0RTT + cc = + cc1 + { ccResumption = res + , ccUse0RTT = True + } + runCnoOp cc ms `shouldThrow` transportError + _ -> do + putStrLn + "Warning: 0-RTT is not possible. Skipping this test. Use \"h3spec -s 0-RTT\" next time." + when (ccDebugLog cc0) $ print mres + +---------------------------------------------------------------- + +addHook :: ClientConfig -> (Hooks -> Hooks) -> ClientConfig +addHook cc modify = cc' + where + cc' = cc{ccHooks = modify $ ccHooks cc} + +setOnPlainCreated :: (EncryptionLevel -> Plain -> Plain) -> Hooks -> Hooks +setOnPlainCreated f hooks = hooks{onPlainCreated = f} + +setOnTransportParametersCreated :: (Parameters -> Parameters) -> Hooks -> Hooks +setOnTransportParametersCreated f hooks = hooks{onTransportParametersCreated = f} + +setOnTLSExtensionCreated :: ([ExtensionRaw] -> [ExtensionRaw]) -> Hooks -> Hooks +setOnTLSExtensionCreated f params = params{onTLSExtensionCreated = f} + +setOnTLSHandshakeCreated + :: ([(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool)) + -> Hooks + -> Hooks +setOnTLSHandshakeCreated f hooks = hooks{onTLSHandshakeCreated = f} + +---------------------------------------------------------------- + +rrBits :: EncryptionLevel -> EncryptionLevel -> Plain -> Plain +rrBits lvl0 lvl plain + | lvl0 == lvl = + if plainPacketNumber plain /= 0 + then plain{plainFlags = Flags 0x08} + else plain + | otherwise = plain + +dropInitialSourceConnectionId :: Parameters -> Parameters +dropInitialSourceConnectionId params = params{initialSourceConnectionId = Nothing} + +dummyCID :: Maybe CID +dummyCID = Just $ toCID "DUMMY" + +setOriginalDestinationConnectionId :: Parameters -> Parameters +setOriginalDestinationConnectionId params = params{originalDestinationConnectionId = dummyCID} + +setPreferredAddress :: Parameters -> Parameters +setPreferredAddress params = params{preferredAddress = Just prefAddr} + where + prefAddr = + BS.concat + [ "\x7f\x00\x00\x01" + , "\x01\xbb" + , "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" + , "\x00\x00" + , "\x08" + , "\x00\x01\x02\x03\x04\x05\x06\x07" + , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f" + ] + +setRetrySourceConnectionId :: Parameters -> Parameters +setRetrySourceConnectionId params = params{retrySourceConnectionId = dummyCID} + +setStatelessResetToken :: Parameters -> Parameters +setStatelessResetToken params = params{statelessResetToken = Just $ StatelessResetToken "DUMMY"} + +---------------------------------------------------------------- + +setMaxUdpPayloadSize :: Parameters -> Parameters +setMaxUdpPayloadSize params = params{maxUdpPayloadSize = 1090} + +setAckDelayExponent :: Parameters -> Parameters +setAckDelayExponent params = params{ackDelayExponent = 30} + +setMaxAckDelay :: Parameters -> Parameters +setMaxAckDelay params = params{maxAckDelay = 2 ^ (15 :: Int)} + +---------------------------------------------------------------- + +largeOffset :: EncryptionLevel -> Plain -> Plain +largeOffset lvl plain + | lvl == RTT1Level = plain{plainFrames = fake : plainFrames plain} + | otherwise = plain + where + fake = StreamF 0 100000000 ["GET /\r\n"] True + +largeStreamId :: EncryptionLevel -> Plain -> Plain +largeStreamId lvl plain + | lvl == RTT1Level = plain{plainFrames = fake : plainFrames plain} + | otherwise = plain + where + fake = StreamF 1000000000 0 ["GET /\r\n"] True + +unknownFrame :: EncryptionLevel -> Plain -> Plain +unknownFrame lvl plain + | lvl == RTT1Level = + plain{plainFrames = UnknownFrame 0x20 : plainFrames plain} + | otherwise = plain + +handshakePathChallenge :: EncryptionLevel -> Plain -> Plain +handshakePathChallenge lvl plain + | lvl == HandshakeLevel = + plain{plainFrames = PathChallenge (PathData "01234567") : plainFrames plain} + | otherwise = plain + +noFrames :: EncryptionLevel -> Plain -> Plain +noFrames lvl plain + | lvl == RTT1Level = + plain + { plainFrames = [] + , plainMarks = set4bytesPN $ setNoPaddings $ plainMarks plain + } + | otherwise = plain + +handshakeDone :: EncryptionLevel -> Plain -> Plain +handshakeDone lvl plain + | lvl == RTT1Level = plain{plainFrames = HandshakeDone : plainFrames plain} + | otherwise = plain + +newToken :: EncryptionLevel -> Plain -> Plain +newToken lvl plain + | lvl == RTT1Level = + plain{plainFrames = NewToken "DUMMY" : plainFrames plain} + | otherwise = plain + +localInitiatedNotCreatedYet :: EncryptionLevel -> Plain -> Plain +localInitiatedNotCreatedYet lvl plain + | lvl == RTT1Level = + plain{plainFrames = StreamF 1 0 [""] False : plainFrames plain} + | otherwise = plain + +sendOnlyStream :: EncryptionLevel -> Plain -> Plain +sendOnlyStream lvl plain + | lvl == RTT1Level = + plain{plainFrames = StreamF 3 0 [""] False : plainFrames plain} + | otherwise = plain + +resetStrm :: EncryptionLevel -> Plain -> Plain +resetStrm lvl plain + | lvl == RTT1Level = + plain + { plainFrames = ResetStream 3 (ApplicationProtocolError 0) 0 : plainFrames plain + } + | otherwise = plain + +stopSending :: EncryptionLevel -> Plain -> Plain +stopSending lvl plain + | lvl == RTT1Level = + plain + { plainFrames = StopSending 101 (ApplicationProtocolError 0) : plainFrames plain + } + | otherwise = plain + +maxStreamData :: EncryptionLevel -> Plain -> Plain +maxStreamData lvl plain + | lvl == RTT1Level = + plain{plainFrames = MaxStreamData 101 1000000 : plainFrames plain} + | otherwise = plain + +maxStreamData2 :: EncryptionLevel -> Plain -> Plain +maxStreamData2 lvl plain + | lvl == RTT1Level = + plain{plainFrames = MaxStreamData 2 1000000 : plainFrames plain} + | otherwise = plain + +maxStreams' :: EncryptionLevel -> Plain -> Plain +maxStreams' lvl plain + | lvl == RTT1Level = + plain + { plainFrames = MaxStreams Bidirectional (2 ^ (60 :: Int) + 1) : plainFrames plain + } + | otherwise = plain + +streamsBlocked :: EncryptionLevel -> Plain -> Plain +streamsBlocked lvl plain + | lvl == RTT1Level = + plain + { plainFrames = + StreamsBlocked Bidirectional (2 ^ (60 :: Int) + 1) : plainFrames plain + } + | otherwise = plain + +newConnectionID :: (Frame -> Frame) -> EncryptionLevel -> Plain -> Plain +newConnectionID f lvl plain + | lvl == RTT1Level = plain{plainFrames = map f $ plainFrames plain} + | otherwise = plain + +ncidZeroCID :: Frame -> Frame +ncidZeroCID (NewConnectionID cidinfo0 rpt) = NewConnectionID cidinfo rpt + where + cidinfo = cidinfo0{cidInfoCID = CID ""} +ncidZeroCID frame = frame + +ncidLargeRPT :: Frame -> Frame +ncidLargeRPT (NewConnectionID cidinfo rpt) = NewConnectionID cidinfo (rpt + 10) +ncidLargeRPT frame = frame + +---------------------------------------------------------------- + +cryptoKeyUpdate + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +cryptoKeyUpdate [(HandshakeLevel, fin)] = ([(HandshakeLevel, BS.append fin "\x18\x00\x00\x01\x01")], False) +cryptoKeyUpdate lcs = (lcs, False) + +cryptoKeyUpdate2 + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +-- [] is intentionally created in RTT1Level for h3spec +cryptoKeyUpdate2 [] = ([(RTT1Level, "\x18\x00\x00\x01\x01")], False) +cryptoKeyUpdate2 lcs = (lcs, False) + +cryptoEndOfEarlyData + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +cryptoEndOfEarlyData [(HandshakeLevel, fin)] = ([(HandshakeLevel, BS.append "\x05\x00\x00\x00" fin)], False) +cryptoEndOfEarlyData lcs = (lcs, False) + +crypto0RTT + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +crypto0RTT [(InitialLevel, ch)] = ([(InitialLevel, ch), (RTT0Level, "\x08\x00\x00\x02\x00\x00")], True) +crypto0RTT lcs = (lcs, False) + +---------------------------------------------------------------- + +transportError :: QUICException -> Bool +transportError (TransportErrorIsReceived te _) = te `elem` [ProtocolViolation, InternalError] +transportError _ = False + +-- Transport Sec 11: +-- In particular, an endpoint MAY use any applicable error code when +-- it detects an error condition; a generic error code (such as +-- PROTOCOL_VIOLATION or INTERNAL_ERROR) can always be used in place +-- of specific error codes. +transportErrorsIn :: [TransportError] -> QUICException -> Bool +transportErrorsIn tes qe@(TransportErrorIsReceived te _) = (te `elem` tes) || transportError qe +transportErrorsIn _ _ = False + +cryptoErrorX :: QUICException -> Bool +cryptoErrorX (TransportErrorIsReceived te _) = te `elem` [cryptoError TLS.InternalError, cryptoError TLS.HandshakeFailure] +cryptoErrorX _ = False + +-- Crypto Sec 4.8: QUIC permits the use of a generic code in place of +-- a specific error code; see Section 11 of [QUIC-TRANSPORT]. For TLS +-- alerts, this includes replacing any alert with a generic alert, +-- such as handshake_failure (0x128 in QUIC). Endpoints MAY use a +-- generic error code to avoid possibly exposing confidential +-- information. +cryptoErrorsIn :: [TLS.AlertDescription] -> QUICException -> Bool +cryptoErrorsIn tes qe@(TransportErrorIsReceived te _) = (te `elem` map cryptoError tes) || cryptoErrorX qe +cryptoErrorsIn _ _ = False diff --git a/h3spec.cabal b/h3spec.cabal new file mode 100644 --- /dev/null +++ b/h3spec.cabal @@ -0,0 +1,33 @@ +name: h3spec +version: 0.1.10 +synopsis: QUIC +description: Test tool for error cases of QUIC and HTTP/3 +license: BSD3 +license-file: LICENSE +author: Kazu Yamamoto +maintainer: kazu@iij.ad.jp +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: ChangeLog.md +cabal-version: >= 1.10 + +executable h3spec + default-language: Haskell2010 + hs-source-dirs: . + main-is: h3spec.hs + other-modules: HTTP3Error + TransportError + Paths_h3spec + ghc-options: -Wall -threaded -rtsopts + build-depends: base >= 4.9 && < 5 + , bytestring + , hspec + , hspec-core + , http-types + , http3 >= 0.0.10 + , network + , quic >= 0.1.20 && < 0.2 + , tls + , unliftio + default-extensions: Strict StrictData diff --git a/h3spec.hs b/h3spec.hs new file mode 100644 --- /dev/null +++ b/h3spec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (when) +import Data.List (foldl', intersperse) +import Data.Version (showVersion) +import qualified Network.HTTP3.Client as H3 +import Network.QUIC.Internal +import System.Console.GetOpt +import System.Environment (getArgs, withArgs) +import System.Exit (exitFailure, exitSuccess) +import qualified Test.Hspec.Core.Runner as H + +import HTTP3Error +import qualified Paths_h3spec as P +import TransportError + +data Options = Options + { optVersion :: Bool + , optDebugLog :: Bool + , optValidate :: Bool + , optMatch :: [String] + , optSkip :: [String] + , optQLogDir :: Maybe FilePath + , optKeyLogFile :: Maybe FilePath + , optTimeout :: Int + } + deriving (Show) + +defaultOptions :: Options +defaultOptions = + Options + { optVersion = False + , optDebugLog = False + , optValidate = True + , optMatch = [] + , optSkip = [] + , optQLogDir = Nothing + , optKeyLogFile = Nothing + , optTimeout = 2000 -- 2 milliseconds + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['v'] + ["version"] + (NoArg (\o -> o{optVersion = True})) + "Print version" + , Option + ['d'] + ["debug"] + (NoArg (\o -> o{optDebugLog = True})) + "print debug info" + , Option + ['m'] + ["match"] + (ReqArg (\m o -> o{optMatch = m : optMatch o}) "") + "Select test cases" + , Option + ['s'] + ["skip"] + (ReqArg (\m o -> o{optSkip = m : optSkip o}) "") + "Skip test cases" + , Option + ['q'] + ["qlog-dir"] + (ReqArg (\dir o -> o{optQLogDir = Just dir}) "") + "directory to store qlog" + , Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['t'] + ["timeout"] + (ReqArg (\ms o -> o{optTimeout = read ms}) "") + "timeout for each test case (2000)" + , Option + ['n'] + ["no-validate"] + (NoArg (\o -> o{optValidate = False})) + "no validating server certificates" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + exitFailure + +usage :: String +usage = "Usage: h3spec " + +main :: IO () +main = do + args0 <- getArgs + (opts, args) <- case getOpt Permute options args0 of + (o, n, []) -> return (foldl' (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs + when (optVersion opts) $ do + putStrLn $ "h3spec " ++ showVersion P.version + exitSuccess + (host, port) <- case args of + [h, p] -> return (h, p) + _ -> showUsageAndExit "" + let cc = + defaultClientConfig + { ccServerName = host + , ccPortName = port + , ccALPN = \_ -> return $ Just ["h3", "h3-29", "hq-interop", "hq-29"] + , ccDebugLog = optDebugLog opts + , ccQLog = optQLogDir opts + , ccKeyLog = getLogger $ optKeyLogFile opts + , ccValidate = optValidate opts + } + qcArgs0 + | null (optMatch opts) = [] + | otherwise = + "--match" : (intersperse "--match" $ reverse $ optMatch opts) + qcArgs + | null (optSkip opts) = qcArgs0 + | otherwise = + "--skip" : (intersperse "--skip" $ reverse $ optSkip opts) + h3cc = H3.ClientConfig "https" host + ms = optTimeout opts + H.readConfig H.defaultConfig qcArgs + >>= withArgs [] . H.runSpec (transportErrorSpec cc ms >> h3ErrorSpec cc h3cc ms) + >>= H.evaluateSummary + +getLogger :: Maybe FilePath -> (String -> IO ()) +getLogger Nothing = \_ -> return () +getLogger (Just file) = \msg -> appendFile file (msg ++ "\n")