quic-0.3.8: test/Config.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Config (
makeTestServerConfig,
makeTestServerConfigR,
testClientConfig,
testClientConfigR,
setServerQlog,
prepareQlog,
setClientQlog,
withPipe,
withPipeStray,
Scenario (..),
newSessionManager,
) where
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import Data.Bits ((.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Network.Socket
import Network.Socket.ByteString
import Network.TLS hiding (Version)
#ifdef QLOG
import System.Directory (createDirectoryIfMissing)
#endif
import Network.QUIC.Client
import Network.QUIC.Internal
makeTestServerConfig :: IO ServerConfig
makeTestServerConfig = do
cred <-
either error id
<$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem"
let credentials = Credentials [cred]
return
testServerConfig
{ scCredentials = credentials
, scALPN = Just chooseALPN
}
testServerConfig :: ServerConfig
testServerConfig =
defaultServerConfig
{ -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug)
scAddresses = [("127.0.0.1", 50003)]
, scParameters =
(scParameters defaultServerConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
makeTestServerConfigR :: IO ServerConfig
makeTestServerConfigR = do
cred <-
either error id
<$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem"
let credentials = Credentials [cred]
return $
setServerQlog
testServerConfigR
{ scCredentials = credentials
, scALPN = Just chooseALPN
}
testServerConfigR :: ServerConfig
testServerConfigR =
defaultServerConfig
{ -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug)
scAddresses = [("127.0.0.1", 50003)]
, scParameters =
(scParameters defaultServerConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
testClientConfig :: ClientConfig
testClientConfig =
defaultClientConfig
{ ccServerName = "127.0.0.1"
, ccPortName = "50003"
, ccValidate = False
, ccDebugLog = True
, ccParameters =
(ccParameters defaultClientConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
testClientConfigR :: ClientConfig
testClientConfigR =
defaultClientConfig
{ ccServerName = "127.0.0.1"
, ccPortName = "50002"
, ccValidate = False
, ccDebugLog = True
, ccParameters =
(ccParameters defaultClientConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
#ifdef QLOG
-- | Write qlog for the connections that go through 'withPipe'.
--
-- These are the tests that lose packets on purpose, and so the ones that
-- stall. A stall costs the idle timeout and reports a test name and
-- \"ConnectionIsTimeout\", which says nothing about why; the qlog says which
-- packets went where, what the congestion window was doing and when a timer
-- fired. Two stalls found at a rate of one run in a few hundred were read
-- straight off these traces, and neither would have been diagnosable
-- without them. CI keeps the directory when a job fails.
-- | Where qlog goes when the @qlog@ flag is on.
qlogDir :: FilePath
qlogDir = "qlog"
#endif
-- | Create 'qlogDir' if the tests are going to write into it.
--
-- The directory used to be the CI's job, and a checkout without it -- a fresh
-- clone, or a @git clean@ -- failed 33 examples with @openFile: does not
-- exist@, which says nothing about qlog. It is the test suite's directory,
-- so the test suite makes it.
prepareQlog :: IO ()
#ifdef QLOG
prepareQlog = createDirectoryIfMissing True qlogDir
#else
prepareQlog = return ()
#endif
setServerQlog :: ServerConfig -> ServerConfig
#ifdef QLOG
setServerQlog sc = sc{scQLog = Just qlogDir}
#else
setServerQlog sc = sc
#endif
setClientQlog :: ClientConfig -> ClientConfig
#ifdef QLOG
setClientQlog cc = cc{ccQLog = Just qlogDir}
#else
setClientQlog cc = cc
#endif
data Scenario
= Randomly Int
| DropClientPacket [Int]
| DropServerPacket [Int]
| -- | Hold the n-th datagram from the client back for a second.
DelayClientPacket Int
| -- | Hold the n-th datagram from the server back for a second.
DelayServerPacket Int
withPipe :: Scenario -> IO () -> IO ()
withPipe = withPipeWith False
-- | 'withPipe', with one short-header datagram delivered to the relay's
-- socket before the relay starts reading.
--
-- That is what the CONNECTION_CLOSE of the connection that just closed looks
-- like when it lands after this socket has taken over the port, and taking it
-- for the client ties the relay to a peer with nothing left to say. The test
-- that uses this fails within the idle timeout if the relay ever goes back to
-- latching onto the first datagram it sees.
withPipeStray :: Scenario -> IO () -> IO ()
withPipeStray = withPipeWith True
withPipeWith :: Bool -> Scenario -> IO () -> IO ()
withPipeWith stray scenario body = do
addrC <- resolve "50002"
let saC = addrAddress addrC
addrS <- resolve "50003"
let saS = addrAddress addrS
irefC <- newIORef 0
irefS <- newIORef 0
E.bracket (openSocket addrC) close $ \sockC ->
E.bracket (openSocket addrS) close $ \sockS -> do
setSocketOption sockC ReuseAddr 1
setSocketOption sockS ReuseAddr 1
bind sockC saC
-- Bound, not connected. A connected UDP socket turns an ICMP
-- port-unreachable from the peer into ECONNREFUSED on the next
-- operation, and the peers here come and go with every test, so
-- the relay was being killed by a reply to something it had sent
-- to an address that had just closed. It surfaced on the
-- receive, not the send:
--
-- DIED C->S: Network.Socket.recvBuf: does not exist
-- (Connection refused)
--
-- and since these are forkIO threads with nobody watching, the
-- relay simply stopped. The client then sent Initial packets
-- until the idle timeout and heard nothing.
addrAny <- resolve "0"
bind sockS $ addrAddress addrAny
when stray $
E.bracket (openSocket addrC) close $ \sock ->
void $ sendTo sock (BS.pack [0x40, 1, 2, 3]) saC
-- The relaying threads have to stop before the sockets close.
-- Run at the end of body instead, the kills are skipped whenever
-- body throws, and the threads are then left in recv on a socket
-- the bracket has just closed. That surfaces as "threadWait:
-- invalid argument (Bad file descriptor)" from a thread nobody is
-- watching, and buries whatever the test was really failing on.
E.bracket (startRelay saS sockC sockS irefC irefS) stopRelay $ \_ -> body
where
startRelay saS sockC sockS irefC irefS = do
-- Where to send what comes back from the server. Set once the client
-- has introduced itself, which is before the server can have anything
-- to say about it.
peerRef <- newIORef Nothing
-- from client
tid0 <- forkIO $ do
-- Wait for the client to introduce itself, and take the first
-- long-header packet rather than the first datagram.
--
-- These sockets use one fixed port, so the socket for this test
-- binds it a fraction of a millisecond after the previous test
-- closed its own. The client of that test signs off with a
-- CONNECTION_CLOSE, and when that lands after the handover it is
-- this socket that receives it. Connecting to its sender ties
-- the relay to a peer with nothing left to say, and the kernel
-- then drops every datagram from the client we are here to
-- relay: it sends Initial packets until the idle timeout and
-- hears nothing, the server never sees the connection at all.
--
-- A client always opens with a long header; a leftover from an
-- established connection is a short one. That tells them apart.
(bs, saO) <- waitForClientHello sockC
writeIORef peerRef $ Just saO
n0 <- atomicModifyIORef' irefC $ \x -> (x + 1, x)
dropPacket0 <- shouldDrop scenario True n0
unless dropPacket0 $ void $ sendTo sockS bs saS
forever $ do
(bs1, sa) <- recvFrom sockC 2048
-- Only from the client we latched onto. The connect this
-- replaces did that in the kernel; doing it here keeps
-- leftovers from the connection that just closed from being
-- counted, which would shift the drop indices.
when (sa == saO) $ do
n <- atomicModifyIORef' irefC $ \x -> (x + 1, x)
dropPacket <- shouldDrop scenario True n
let isCC = BS.length bs1 < 200
when (isCC || not dropPacket) $
delayIf (shouldDelay scenario True n) $
void $
sendTo sockS bs1 saS
-- from server
tid1 <- forkIO $ forever $ do
(bs, _) <- recvFrom sockS 2048
n <- atomicModifyIORef' irefS $ \x -> (x + 1, x)
dropPacket <- shouldDrop scenario False n
let isCC = BS.length bs < 200
when (isCC || not dropPacket) $ do
mpeer <- readIORef peerRef
forM_ mpeer $ \sa ->
delayIf (shouldDelay scenario False n) $ void $ sendTo sockC bs sa
return (tid0, tid1)
stopRelay (tid0, tid1) = killThread tid0 >> killThread tid1
waitForClientHello sockC = do
(bs, saO) <- recvFrom sockC 2048
if not (BS.null bs) && BS.head bs .&. 0x80 /= 0
then return (bs, saO)
else waitForClientHello sockC
hints =
defaultHints
{ addrSocketType = Network.Socket.Datagram
, addrFlags = [AI_NUMERICHOST]
, addrFamily = AF_INET
}
resolve port =
NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port)
shouldDrop (Randomly n) _ _ = do
w <- getRandomOneByte
return ((w `mod` fromIntegral n) == 0)
shouldDrop (DropClientPacket ns) fromC pn
| fromC = return (pn `elem` ns)
| otherwise = return False
shouldDrop (DropServerPacket ns) fromC pn
| fromC = return False
| otherwise = return (pn `elem` ns)
shouldDrop _ _ _ = return False
shouldDelay (DelayClientPacket k) fromC pn = fromC && pn == k
shouldDelay (DelayServerPacket k) fromC pn = not fromC && pn == k
shouldDelay _ _ _ = False
-- The packets that follow go ahead of the one held back.
--
-- Long enough for the data to be sent again and the stream closed before
-- it lands, which is what the test is about, and no longer: it was a
-- second, and a second is two and a half of these tests' worth of
-- everything else.
delayIf True send_ = void $ forkIO $ threadDelay delayTime >> send_
delayIf False send_ = send_
chooseALPN :: Version -> [ByteString] -> IO ByteString
chooseALPN _ver protos = return $ case mh3idx of
Nothing -> case mhqidx of
Nothing -> ""
Just _ -> "hq"
Just h3idx -> case mhqidx of
Nothing -> "h3"
Just hqidx -> if h3idx < hqidx then "h3" else "hq"
where
mh3idx = "h3" `L.elemIndex` protos
mhqidx = "hq" `L.elemIndex` protos
newSessionManager :: IO SessionManager
newSessionManager = sessionManager <$> newIORef Nothing
sessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager
sessionManager ref =
noSessionManager
{ sessionEstablish = establish
, sessionResume = resume
, sessionResumeOnlyOnce = resume
, sessionInvalidate = \_ -> return ()
, sessionUseTicket = False
}
where
establish sid sdata = writeIORef ref (Just (sid, sdata)) >> return Nothing
resume sid = do
mx <- readIORef ref
case mx of
Nothing -> return Nothing
Just (s, d)
| s == sid -> return $ Just d
| otherwise -> return Nothing
-- | How long 'DelayClientPacket' and 'DelayServerPacket' hold a datagram.
delayTime :: Int
delayTime = 100000