diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.1.3 + +- Supporting `tls` v1.8.0. + ## 0.1.2 - Using "crypton" instead of "cryptonite". diff --git a/Network/QUIC/Client/Run.hs b/Network/QUIC/Client/Run.hs --- a/Network/QUIC/Client/Run.hs +++ b/Network/QUIC/Client/Run.hs @@ -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 diff --git a/Network/QUIC/Config.hs b/Network/QUIC/Config.hs --- a/Network/QUIC/Config.hs +++ b/Network/QUIC/Config.hs @@ -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 () } ---------------------------------------------------------------- diff --git a/Network/QUIC/Connection/Queue.hs b/Network/QUIC/Connection/Queue.hs --- a/Network/QUIC/Connection/Queue.hs +++ b/Network/QUIC/Connection/Queue.hs @@ -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) diff --git a/Network/QUIC/Handshake.hs b/Network/QUIC/Handshake.hs --- a/Network/QUIC/Handshake.hs +++ b/Network/QUIC/Handshake.hs @@ -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) diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -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 diff --git a/Network/QUIC/Sender.hs b/Network/QUIC/Sender.hs --- a/Network/QUIC/Sender.hs +++ b/Network/QUIC/Sender.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/QUIC/Server/Run.hs b/Network/QUIC/Server/Run.hs --- a/Network/QUIC/Server/Run.hs +++ b/Network/QUIC/Server/Run.hs @@ -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 diff --git a/Network/QUIC/Types/Exception.hs b/Network/QUIC/Types/Exception.hs --- a/Network/QUIC/Types/Exception.hs +++ b/Network/QUIC/Types/Exception.hs @@ -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 diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -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, diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -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 diff --git a/test/IOSpec.hs b/test/IOSpec.hs --- a/test/IOSpec.hs +++ b/test/IOSpec.hs @@ -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 diff --git a/test/TransportError.hs b/test/TransportError.hs --- a/test/TransportError.hs +++ b/test/TransportError.hs @@ -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]