quic 0.1.2 → 0.1.3
raw patch · 13 files changed
+143/−87 lines, 13 filesdep ~tls
Dependency ranges changed: tls
Files
- ChangeLog.md +4/−0
- Network/QUIC/Client/Run.hs +3/−1
- Network/QUIC/Config.hs +2/−0
- Network/QUIC/Connection/Queue.hs +3/−0
- Network/QUIC/Handshake.hs +7/−2
- Network/QUIC/Receiver.hs +6/−1
- Network/QUIC/Sender.hs +23/−9
- Network/QUIC/Server/Run.hs +8/−4
- Network/QUIC/Types/Exception.hs +1/−1
- quic.cabal +2/−2
- test/HandshakeSpec.hs +38/−25
- test/IOSpec.hs +45/−41
- test/TransportError.hs +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.1.3++- Supporting `tls` v1.8.0.+ ## 0.1.2 - Using "crypton" instead of "cryptonite".
Network/QUIC/Client/Run.hs view
@@ -86,7 +86,9 @@ case er of Left () -> E.throwIO MustNotReached Right r -> return r- E.trySyncOrAsync runThreads >>= closure conn ldcc+ ex <- E.trySyncOrAsync runThreads+ sendFinal conn+ closure conn ldcc ex where open = createClientConnection conf verInfo clse connRes = do
Network/QUIC/Config.hs view
@@ -23,6 +23,7 @@ , onTLSExtensionCreated :: [ExtensionRaw] -> [ExtensionRaw] , onTLSHandshakeCreated :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) , onResetStreamReceived :: Stream -> ApplicationProtocolError -> IO ()+ , onServerReady :: IO () } -- | Default hooks.@@ -34,6 +35,7 @@ , onTLSExtensionCreated = id , onTLSHandshakeCreated = (, False) , onResetStreamReceived = \_ _ -> return ()+ , onServerReady = return () } ----------------------------------------------------------------
Network/QUIC/Connection/Queue.hs view
@@ -21,6 +21,9 @@ takeOutputSTM :: Connection -> STM Output takeOutputSTM conn = readTQueue (outputQ conn) +tryTakeOutput :: Connection -> IO (Maybe Output)+tryTakeOutput conn = atomically $ tryReadTQueue (outputQ conn)+ tryPeekOutput :: Connection -> IO (Maybe Output) tryPeekOutput conn = atomically $ tryPeekTQueue (outputQ conn)
Network/QUIC/Handshake.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -307,8 +308,12 @@ sendCCTLSAlert a msg = closeConnection (cryptoError a) msg getErrorCause :: TLS.TLSException -> TLS.TLSError-getErrorCause (TLS.HandshakeFailed e) = e-getErrorCause (TLS.Terminated _ _ e) = e+getErrorCause (TLS.Terminated _ _ e) = e+getErrorCause (TLS.HandshakeFailed e) = e+#if MIN_VERSION_tls(1,8,0)+getErrorCause (TLS.PostHandshake e) = e+getErrorCause (TLS.Uncontextualized e) = e+#endif getErrorCause e = let msg = "unexpected TLS exception: " ++ show e in TLS.Error_Protocol (msg, True, TLS.InternalError)
Network/QUIC/Receiver.hs view
@@ -37,7 +37,12 @@ ito <- readMinIdleTimeout conn mx <- timeout ito $ connRecv conn -- fixme: taking minimum with peer's one case mx of- Nothing -> E.throwIO ConnectionIsTimeout+ Nothing -> do+ st <- getConnectionState conn+ let msg0 | isClient conn = "Client"+ | otherwise = "Server"+ msg = msg0 ++ " " ++ show st+ E.throwIO $ ConnectionIsTimeout msg Just x -> return x loopHandshake = do rpkt <- recvTimeout
Network/QUIC/Sender.hs view
@@ -3,6 +3,7 @@ module Network.QUIC.Sender ( sender , mkHeader+ , sendFinal ) where import qualified Data.ByteString as BS@@ -206,17 +207,30 @@ | SwStrm TxStreamData sender :: Connection -> IO ()-sender conn = handleLogT logAction body+sender conn = handleLogT logAction $ forever $ sendP conn where- body = forever $ do- x <- atomically ((SwPing <$> takePingSTM (connLDCC conn))- `orElse` (SwOut <$> takeOutputSTM conn)- `orElse` (SwStrm <$> takeSendStreamQSTM conn))- case x of- SwPing lvl -> sendPingPacket conn lvl- SwOut out -> sendOutput conn out- SwStrm tx -> sendTxStreamData conn tx logAction msg = connDebugLog conn ("debug: sender: " <> msg)++sendP :: Connection -> IO ()+sendP conn = do+ x <- atomically ((SwPing <$> takePingSTM (connLDCC conn))+ `orElse` (SwOut <$> takeOutputSTM conn)+ `orElse` (SwStrm <$> takeSendStreamQSTM conn))+ case x of+ SwPing lvl -> sendPingPacket conn lvl+ SwOut out -> sendOutput conn out+ SwStrm tx -> sendTxStreamData conn tx++sendFinal :: Connection -> IO ()+sendFinal conn = loop 30+ where+ loop :: Int -> IO ()+ loop 0 = return ()+ loop n = do+ mx <- timeout (Microseconds 10) $ sendP conn+ case mx of+ Nothing -> return ()+ Just () -> loop (n - 1) ----------------------------------------------------------------
Network/QUIC/Server/Run.hs view
@@ -43,9 +43,11 @@ run :: ServerConfig -> (Connection -> IO ()) -> IO () run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do baseThreadId <- myThreadId- E.bracket setup teardown $ \(dispatch,_) -> forever $ do- acc <- accept dispatch- void $ forkIO (runServer conf server dispatch baseThreadId acc)+ E.bracket setup teardown $ \(dispatch,_) -> do+ onServerReady $ scHooks conf+ forever $ do+ acc <- accept dispatch+ void $ forkIO (runServer conf server dispatch baseThreadId acc) where doDebug = isJust $ scDebugLog conf debugLog msg | doDebug = stdoutLogger ("run: " <> msg)@@ -92,7 +94,9 @@ case er of Left () -> E.throwIO MustNotReached Right r -> return r- E.trySyncOrAsync runThreads >>= closure conn ldcc+ ex <- E.trySyncOrAsync runThreads+ sendFinal conn+ closure conn ldcc ex where open = createServerConnection conf dispatch acc baseThreadId clse connRes = do
Network/QUIC/Types/Exception.hs view
@@ -15,7 +15,7 @@ | TransportErrorIsSent TransportError ReasonPhrase | ApplicationProtocolErrorIsReceived ApplicationProtocolError ReasonPhrase | ApplicationProtocolErrorIsSent ApplicationProtocolError ReasonPhrase- | ConnectionIsTimeout+ | ConnectionIsTimeout String | ConnectionIsReset | StreamIsClosed | HandshakeFailed TLS.AlertDescription -- failed in my side
quic.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: quic-version: 0.1.2+version: 0.1.3 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -143,7 +143,7 @@ psqueues, random >=1.2, stm,- tls >=1.5.6,+ tls >=1.7.0, unix-time, unliftio >=0.2.18, unliftio-core,
test/HandshakeSpec.hs view
@@ -22,28 +22,34 @@ spec = do sc0' <- runIO makeTestServerConfig smgr <- runIO newSessionManager- let sc0 = sc0' { scSessionManager = smgr }+ var <- runIO newEmptyMVar+ let sc0 = sc0' { scSessionManager = smgr+ , scHooks = (scHooks sc0') {+ onServerReady = putMVar var ()+ }+ }+ let waitS = takeMVar var :: IO () describe "handshake" $ do it "can handshake in the normal case" $ do let cc = testClientConfig sc = sc0- testHandshake cc sc FullHandshake+ testHandshake cc sc waitS FullHandshake it "can handshake in the case of TLS hello retry" $ do let cc = testClientConfig sc = sc0 { scGroups = [P256] }- testHandshake cc sc HelloRetryRequest+ testHandshake cc sc waitS HelloRetryRequest it "can handshake in the case of QUIC retry" $ do let cc = testClientConfig sc = sc0 { scRequireRetry = True }- testHandshake cc sc FullHandshake+ testHandshake cc sc waitS FullHandshake it "can handshake in the case of resumption" $ do let cc = testClientConfig sc = sc0- testHandshake2 cc sc (FullHandshake, PreSharedKey) False+ testHandshake2 cc sc waitS (FullHandshake, PreSharedKey) False it "can handshake in the case of 0-RTT" $ do let cc = testClientConfig sc = sc0 { scUse0RTT = True }- testHandshake2 cc sc (FullHandshake, RTT0) True+ testHandshake2 cc sc waitS (FullHandshake, RTT0) True it "fails with unknown server certificate" $ do let cc1 = testClientConfig { ccValidate = True -- ouch, default should be reversed@@ -53,7 +59,7 @@ certificateRejected e | TransportErrorIsSent te@(TransportError _) _ <- e = te == cryptoError TLS.CertificateUnknown | otherwise = False- testHandshake3 cc1 cc2 sc certificateRejected+ testHandshake3 cc1 cc2 sc waitS certificateRejected it "fails with no group in common" $ do let cc1 = testClientConfig { ccGroups = [X25519] } cc2 = testClientConfig { ccGroups = [P256] }@@ -61,7 +67,7 @@ handshakeFailure e | TransportErrorIsReceived te@(TransportError _) _ <- e = te == cryptoError TLS.HandshakeFailure | otherwise = False- testHandshake3 cc1 cc2 sc handshakeFailure+ testHandshake3 cc1 cc2 sc waitS handshakeFailure it "can handshake with large HE from a client" $ do let cc0 = testClientConfig params = (ccParameters cc0) {@@ -69,33 +75,41 @@ } cc = cc0 { ccParameters = params } sc = sc0- testHandshake cc sc FullHandshake+ testHandshake cc sc waitS FullHandshake it "can handshake with large EE from a server (3-times rule)" $ do let cc = testClientConfig params = (scParameters sc0) { grease = Just (BS.pack (replicate 3800 0)) } sc = sc0 { scParameters = params }- testHandshake cc sc FullHandshake+ testHandshake cc sc waitS FullHandshake onE :: IO b -> IO a -> IO a onE h b = E.onException b h -testHandshake :: ClientConfig -> ServerConfig -> HandshakeMode13 -> IO ()-testHandshake cc sc mode = do+testHandshake :: ClientConfig -> ServerConfig -> IO () -> HandshakeMode13 -> IO ()+testHandshake cc sc waitS mode = do concurrently_ server client- threadDelay 50000 where client = do- threadDelay 50000+ waitS C.run cc $ \conn -> do waitEstablished conn handshakeMode <$> getConnectionInfo conn `shouldReturn` mode server = S.run sc $ \conn -> do waitEstablished conn handshakeMode <$> getConnectionInfo conn `shouldReturn` mode- stop conn+ delayedStop conn +delayedStop :: Connection -> IO ()+delayedStop conn = do+ var <- newEmptyMVar+ _ <- forkIO $ do+ threadDelay 100+ putMVar var ()+ takeMVar var+ stop conn+ query :: BS.ByteString -> Connection -> IO () query content conn = do waitEstablished conn@@ -104,10 +118,9 @@ shutdownStream s void $ recvStream s 1024 -testHandshake2 :: ClientConfig -> ServerConfig -> (HandshakeMode13, HandshakeMode13) -> Bool -> IO ()-testHandshake2 cc1 sc (mode1, mode2) use0RTT = do+testHandshake2 :: ClientConfig -> ServerConfig -> IO () -> (HandshakeMode13, HandshakeMode13) -> Bool -> IO ()+testHandshake2 cc1 sc waitS (mode1, mode2) use0RTT = do concurrently_ server client- threadDelay 50000 where runClient cc mode action = C.run cc $ \conn -> do void $ action conn@@ -115,7 +128,7 @@ threadDelay 50000 getResumptionInfo conn client = do- threadDelay 10000+ waitS res <- runClient cc1 mode1 $ query "first" threadDelay 50000 let cc2 = cc1 { ccResumption = res@@ -129,15 +142,15 @@ bs <- recvStream s 1024 sendStream s "bye" closeStream s- when (bs == "second") $ stop conn+ when (bs == "second") $ do+ delayedStop conn -testHandshake3 :: ClientConfig -> ClientConfig -> ServerConfig -> (QUICException -> Bool) -> IO ()-testHandshake3 cc1 cc2 sc selector = do+testHandshake3 :: ClientConfig -> ClientConfig -> ServerConfig -> IO () -> (QUICException -> Bool) -> IO ()+testHandshake3 cc1 cc2 sc waitS selector = do concurrently_ server client- threadDelay 50000 where client = do- threadDelay 50000+ waitS C.run cc1 (query "first") `shouldThrow` selector C.run cc2 (query "second") `shouldReturn` () server = S.run sc $ \conn -> do@@ -145,4 +158,4 @@ recvStream s 1024 `shouldReturn` "second" sendStream s "bye" closeStream s- stop conn+ delayedStop conn
test/IOSpec.hs view
@@ -8,72 +8,79 @@ import UnliftIO.Async import UnliftIO.Concurrent -import qualified Network.QUIC.Client as C import Network.QUIC+import qualified Network.QUIC.Client as C+import Network.QUIC.Internal import Network.QUIC.Server import Config spec :: Spec spec = do- sc <- runIO makeTestServerConfigR+ sc0 <- runIO makeTestServerConfigR+ var <- runIO newEmptyMVar+ let sc = sc0 { scHooks = (scHooks sc0) {+ onServerReady = putMVar var ()+ }+ } let cc = testClientConfigR+ let waitS = takeMVar var :: IO () describe "send & recv" $ do it "can exchange data on random dropping" $ do- withPipe (Randomly 20) $ testSendRecv cc sc 1000+ withPipe (Randomly 20) $ testSendRecv cc sc waitS 1000 it "can exchange data on server 0" $ do- withPipe (DropServerPacket [0]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [0]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 1" $ do- withPipe (DropServerPacket [1]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [1]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 2" $ do- withPipe (DropServerPacket [2]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [2]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 3" $ do- withPipe (DropServerPacket [3]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [3]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 4" $ do- withPipe (DropServerPacket [4]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [4]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 5" $ do- withPipe (DropServerPacket [5]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [5]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 6" $ do- withPipe (DropServerPacket [6]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [6]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 7" $ do- withPipe (DropServerPacket [7]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [7]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 8" $ do- withPipe (DropServerPacket [8]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [8]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 9" $ do- withPipe (DropServerPacket [9]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [9]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 10" $ do- withPipe (DropServerPacket [10]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [10]) $ testSendRecv cc sc waitS 20 it "can exchange data on server 11" $ do- withPipe (DropServerPacket [11]) $ testSendRecv cc sc 20+ withPipe (DropServerPacket [11]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 0" $ do- withPipe (DropClientPacket [0]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [0]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 1" $ do- withPipe (DropClientPacket [1]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [1]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 2" $ do- withPipe (DropClientPacket [2]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [2]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 3" $ do- withPipe (DropClientPacket [3]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [3]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 4" $ do- withPipe (DropClientPacket [4]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [4]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 5" $ do- withPipe (DropClientPacket [5]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [5]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 6" $ do- withPipe (DropClientPacket [6]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [6]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 7" $ do- withPipe (DropClientPacket [7]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [7]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 8" $ do- withPipe (DropClientPacket [8]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [8]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 9" $ do- withPipe (DropClientPacket [9]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [9]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 10" $ do- withPipe (DropClientPacket [10]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [10]) $ testSendRecv cc sc waitS 20 it "can exchange data on client 11" $ do- withPipe (DropClientPacket [11]) $ testSendRecv cc sc 20+ withPipe (DropClientPacket [11]) $ testSendRecv cc sc waitS 20 describe "recvStream" $ do it "don't block if client stop sending first" $ do- withPipe (Randomly 20) $ testRecvStreamClientStopFirst cc sc+ withPipe (Randomly 20) $ testRecvStreamClientStopFirst cc sc waitS it "don't block if server stop sending first" $ do- withPipe (Randomly 20) $ testRecvStreamServerStopFirst cc sc+ withPipe (Randomly 20) $ testRecvStreamServerStopFirst cc sc waitS consumeBytes :: Stream -> Int -> IO () consumeBytes _ 0 = return ()@@ -87,16 +94,15 @@ assertEndOfStream :: Stream -> IO () assertEndOfStream strm = recvStream strm 1024 `shouldReturn` "" -testRecvStreamClientStopFirst :: C.ClientConfig -> ServerConfig -> IO ()-testRecvStreamClientStopFirst cc sc = do+testRecvStreamClientStopFirst :: C.ClientConfig -> ServerConfig -> IO () -> IO ()+testRecvStreamClientStopFirst cc sc waitS = do mvar <- newEmptyMVar void $ concurrently (client mvar) (server mvar)- threadDelay 10000 where aerr = ApplicationProtocolError 0 client mvar = do- threadDelay 10000+ waitS C.run cc $ \conn -> do strm <- stream conn sendStream strm (BS.replicate 10000 0)@@ -114,16 +120,15 @@ putMVar mvar () stop conn -testRecvStreamServerStopFirst :: C.ClientConfig -> ServerConfig -> IO ()-testRecvStreamServerStopFirst cc sc = do+testRecvStreamServerStopFirst :: C.ClientConfig -> ServerConfig -> IO () -> IO ()+testRecvStreamServerStopFirst cc sc waitS = do mvar <- newEmptyMVar void $ concurrently (client mvar) (server mvar)- threadDelay 10000 where aerr = ApplicationProtocolError 0 client mvar = do- threadDelay 10000+ waitS C.run cc $ \conn -> do strm <- stream conn sendStream strm (BS.replicate 10000 0)@@ -139,14 +144,13 @@ putMVar mvar () stop conn -testSendRecv :: C.ClientConfig -> ServerConfig -> Int -> IO ()-testSendRecv cc sc times = do+testSendRecv :: C.ClientConfig -> ServerConfig -> IO () -> Int -> IO ()+testSendRecv cc sc waitS times = do mvar <- newEmptyMVar void $ concurrently (client mvar) (server mvar)- threadDelay 10000 where client mvar = do- threadDelay 10000+ waitS C.run cc $ \conn -> do strm <- stream conn let bs = BS.replicate 10000 0
test/TransportError.hs view
@@ -123,7 +123,7 @@ 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- runC cc ms (\_ -> threadDelay 1000000) `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage]+ 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]