quic-0.3.16: test/Config.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Config (
makeTestServerConfig,
makeTestServerConfigR,
testClientConfig,
testClientConfigR,
setServerQlog,
prepareQlog,
setClientQlog,
withPipe,
withTempDir,
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)
import System.Directory
import System.FilePath ((</>))
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", 15003)]
, 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", 15003)]
, scParameters =
(scParameters defaultServerConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
testClientConfig :: ClientConfig
testClientConfig =
defaultClientConfig
{ ccServerName = "127.0.0.1"
, ccPortName = "15003"
, ccValidate = False
, ccDebugLog = True
, ccParameters =
(ccParameters defaultClientConfig)
{ maxIdleTimeout = Milliseconds 10000
}
}
testClientConfigR :: ClientConfig
testClientConfigR =
defaultClientConfig
{ ccServerName = "127.0.0.1"
, ccPortName = "15002"
, 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 two leftover datagrams delivered to the relay's socket
-- before the relay starts reading: a short-header one and a long-header one.
--
-- That is what the connection that just closed leaves behind when it lands
-- after this socket has taken over the port. A CONNECTION_CLOSE is a
-- short-header packet once the handshake is confirmed and a long-header one
-- before that, and taking either 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, or onto the first long-header one.
withPipeStray :: Scenario -> IO () -> IO ()
withPipeStray = withPipeWith True
withPipeWith :: Bool -> Scenario -> IO () -> IO ()
withPipeWith stray scenario body = do
-- Ports outside the range the kernel hands out for a socket bound to
-- port 0, which is 49152 to 65535 on macOS and 32768 to 60999 on Linux.
-- Inside it, the relay's own socket for the server side, bound to
-- 127.0.0.1:0 below, is now and then given the very port the test
-- server wants, and the server cannot bind it:
--
-- Network.Socket.bind: resource busy (Address already in use)
--
-- 'run' reports that to whoever forked it, which is nobody, so
-- onServerReady never fires and the test fails with "server never
-- became ready". One run in a few hundred, on ports 50002 and 50003.
addrC <- resolve "15002"
let saC = addrAddress addrC
addrS <- resolve "15003"
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 -> do
void $ sendTo sock (BS.pack [0x40, 1, 2, 3]) saC
void $ sendTo sock (BS.pack [0xc0, 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
-- datagram that could be its opening one 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 opens with an Initial packet in a datagram padded to
-- at least 1200 bytes, which RFC 9000 Sec 14.1 requires of it so
-- that the path is known to carry one. Nothing a connection
-- leaves behind is that: a CONNECTION_CLOSE is a short-header
-- packet once the handshake is confirmed and a long-header one
-- before that, and either way it is a fraction of that size.
-- Long header alone does not tell them apart.
--
-- This is a guard, not the cure. A connection that is still
-- running sends datagrams that are a client's opening one in
-- every respect, because that is what they are, and no reading
-- of a datagram can say which test it belongs to. A test that
-- leaves a client behind breaks the next one however this
-- chooses, so a test must not leave one behind.
(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) <- relayRecv sockC
-- 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, _) <- relayRecv sockS
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
-- 'stopRelay' kills these threads and the brackets close the sockets
-- straight after, and a thread blocked in a socket call on Windows is
-- not reachable by 'killThread' -- it would be left in the call and
-- would die of the close instead, from a thread nobody is watching.
relayRecv sock = windowsThreadBlockHack $ recvFrom sock 2048
waitForClientHello sockC = do
(bs, saO) <- relayRecv sockC
if isClientHello bs
then return (bs, saO)
else waitForClientHello sockC
isClientHello bs =
BS.length bs >= 1200 && BS.head bs .&. 0x80 /= 0
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
-- | A directory of our own for a spec to put files in, taken away
-- afterwards.
--
-- Windows will not delete a file that is open, and will refuse for a while
-- after it has been closed as well -- a virus scanner reading what was just
-- written is enough, and that is the normal state of a CI runner. So the
-- removal is given a few seconds to come good rather than failing the test
-- that had already passed. A handle a test really leaks is still caught:
-- it is never released, and the wait runs out.
withTempDir :: String -> (FilePath -> IO a) -> IO a
withTempDir name body = do
tmp <- getTemporaryDirectory
let dir = tmp </> name
E.bracket (newDir dir) removeWhenItCan body
where
newDir dir = do
removeWhenItCan dir
createDirectory dir
return dir
removeWhenItCan dir = go (250 :: Int)
where
go 0 = removePathForcibly dir
go n = do
r <- E.try $ removePathForcibly dir
case r of
Right () -> return ()
Left (_ :: E.IOException) -> threadDelay 20000 >> go (n - 1)