diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,62 @@ # ChangeLog +## 0.3.13 + +One line of debug output that could end the connection it described, and +three ways a failure or a coder left something behind. + +* A debug write can no longer end the connection it describes. With a + debug directory set every line goes to the connection's file and also + to stdout, and a daemon has no stdout to write to: it is closed, or a + pipe whose reader has gone. The write then throws in whichever + protocol thread happened to log, and six of those run under nested + `concurrently_` and take the rest down with them -- so the connection + ended over a line of debug output. The first write of all is the + original CID, before the connection has been built, so the peer heard + nothing at all and saw a handshake that never finished; a later one + arrived as an INTERNAL_ERROR, once 0.3.12 began saying when a + connection ends of something in here. Against mighty that was every + shape we had been chasing at once: the freeze, the CONNECTION_CLOSE + that never came, and the bursts of connections that died together. It + came and went because a stdout that is not a terminal is + block-buffered and it is the flush that fails. The writes now drop an + `IOException` -- only that, an asynchronous exception is not one, so + cancelling a thread that is logging still cancels it. + [#148](https://github.com/kazu-yamamoto/quic/pull/148) + +* The qlog writer goes the same way and for the same reason. It is + called from the sender, the receiver and the closer, the same threads, + and the disk a qlog directory sits on can fill. + [#150](https://github.com/kazu-yamamoto/quic/pull/150) + +* Free what a failed setup took. A connection's setup, a client's, and + the server's own are each the acquire of their own `bracket`, and an + acquire that throws gets no release. A server connection was leaving + two log files, three 2048-byte buffers and a registration in the + dispatcher; a client the same, less a log file and plus its socket, + which nothing else closes because on the ordinary path the closer does + and a connection that never began has no closer; the server itself + every address it had already bound, the dispatchers on them and the + token manager thread. `closure''`, which runs on the way out of every + connection, left its buffers behind if the CONNECTION_CLOSE could not + be encoded. Setup does fail -- a client and a server in one process + pointed at one qlog directory ask for the same file, and the second is + told the file is busy -- and the bursts above were leaking two handles + apiece. + [#149](https://github.com/kazu-yamamoto/quic/pull/149) + +* The header protection mask no longer leaks a buffer for every coder. + It was taken with `mallocBytes` and freed nowhere: 16 bytes under the + AES-GCM ciphers and 32 under ChaCha20-Poly1305, four coders to a + connection at each end, held for the life of the process. A server + taking a thousand connections a second lost about 5GB a day. The + buffer was raw because `getMask` handed it out and the caller read it + after the call had returned, which nothing a garbage collector owns + would survive; the reader is handed in instead now, so the buffer can + be a `ForeignPtr` held across exactly the use. This changes + `Protector` in `Network.QUIC.Internal`. + [#151](https://github.com/kazu-yamamoto/quic/pull/151) + ## 0.3.12 A server that looked frozen, a Stateless Reset half the peers threw away, 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 @@ -10,8 +10,8 @@ ) where import Control.Concurrent -import Control.Concurrent.STM import Control.Concurrent.Async +import Control.Concurrent.STM import qualified Control.Exception as E import Foreign.C.Types import qualified Network.Socket as NS @@ -112,70 +112,79 @@ createClientConnection :: ClientConfig -> VersionInfo -> IO ConnRes createClientConnection conf@ClientConfig{..} verInfo = do (sock, peersa) <- clientSocket ccServerName ccPortName - when ccSockConnected $ NS.connect sock peersa - q <- newRecvQ - sref <- newIORef sock - pathInfo <- newPathInfo peersa - piref <- newIORef $ PeerInfo pathInfo Nothing - let send buf siz - | ccSockConnected = do - s <- readIORef sref - void $ NS.sendBuf s buf siz - | otherwise = do - s <- readIORef sref - PeerInfo pinfo _ <- readIORef piref - void $ NS.sendBufTo s buf siz $ peerSockAddr pinfo - recv = recvClient q - myCID <- newCID - -- Creating peer's CIDDB with the temporary CID. This is - -- overridden by resetPeerCID later since no sequence number is - -- assigned to the temporary CID by spec. - peerCID <- newCID - now <- getTimeMicrosecond - (qLog, qclean) <- dirQLogger ccQLog now peerCID "client" - let debugLog msg - | ccDebugLog = stdoutLogger msg - | otherwise = return () - debugLog $ "Original CID: " <> bhow peerCID - let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID} - peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID} - genSRT <- makeGenStatelessReset - connRecvDatagramQ <- newTQueueIO - conn <- - clientConnection - conf - verInfo - myAuthCIDs - peerAuthCIDs - debugLog - qLog - ccHooks - sref - piref - q - connRecvDatagramQ - send - recv - genSRT - setSockConnected conn ccSockConnected - addResource conn qclean - modifytPeerParameters conn ccResumption - let ver = chosenVersion verInfo - initializeCoder conn InitialLevel $ initialSecrets ver peerCID - setupCryptoStreams conn -- fixme: cleanup - -- RFC9000 \S14.2 - -- "In the absence of these mechanisms, QUIC endpoints SHOULD - -- NOT send datagrams larger than the smallest allowed maximum - -- datagram size." - -- - -- Thus use 1200 bytes for minimum packet size. - let pktSiz0 = fromMaybe (defaultPacketSize peersa) ccPacketSize - pktSiz = (defaultQUICPacketSize `max` pktSiz0) `min` maximumPacketSize peersa - setMaxPacketSize conn pktSiz - setInitialCongestionWindow (connLDCC conn) pktSiz - setAddressValidated pathInfo - let reader = readerClient sock conn -- dies when s0 is closed. - return $ ConnRes conn myAuthCIDs reader + -- As in 'createServerConnection': this is 'run's bracket acquire, so + -- nothing releases what it has taken when it throws. Here that is a + -- socket as well -- 'clse' does not close it, the closer does, and a + -- connection that never began has no closer. + flip E.onException (NS.close sock) $ do + when ccSockConnected $ NS.connect sock peersa + q <- newRecvQ + sref <- newIORef sock + pathInfo <- newPathInfo peersa + piref <- newIORef $ PeerInfo pathInfo Nothing + let send buf siz + | ccSockConnected = do + s <- readIORef sref + void $ NS.sendBuf s buf siz + | otherwise = do + s <- readIORef sref + PeerInfo pinfo _ <- readIORef piref + void $ NS.sendBufTo s buf siz $ peerSockAddr pinfo + recv = recvClient q + myCID <- newCID + -- Creating peer's CIDDB with the temporary CID. This is + -- overridden by resetPeerCID later since no sequence number is + -- assigned to the temporary CID by spec. + peerCID <- newCID + now <- getTimeMicrosecond + (qLog, qclean) <- dirQLogger ccQLog now peerCID "client" + flip E.onException qclean $ do + let debugLog msg + | ccDebugLog = stdoutLogger msg + | otherwise = return () + debugLog $ "Original CID: " <> bhow peerCID + let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID} + peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID} + genSRT <- makeGenStatelessReset + connRecvDatagramQ <- newTQueueIO + conn <- + clientConnection + conf + verInfo + myAuthCIDs + peerAuthCIDs + debugLog + qLog + ccHooks + sref + piref + q + connRecvDatagramQ + send + recv + genSRT + flip E.onException (setDead conn >> freeResources conn) $ do + setSockConnected conn ccSockConnected + modifytPeerParameters conn ccResumption + let ver = chosenVersion verInfo + initializeCoder conn InitialLevel $ initialSecrets ver peerCID + setupCryptoStreams conn -- fixme: cleanup + -- RFC9000 \S14.2 + -- "In the absence of these mechanisms, QUIC endpoints SHOULD + -- NOT send datagrams larger than the smallest allowed maximum + -- datagram size." + -- + -- Thus use 1200 bytes for minimum packet size. + let pktSiz0 = fromMaybe (defaultPacketSize peersa) ccPacketSize + pktSiz = (defaultQUICPacketSize `max` pktSiz0) `min` maximumPacketSize peersa + setMaxPacketSize conn pktSiz + setInitialCongestionWindow (connLDCC conn) pktSiz + setAddressValidated pathInfo + let reader = readerClient sock conn -- dies when s0 is closed. + -- Handing the qlog over. Nothing below can throw, so from here + -- 'freeResources' is the only releaser. + addResource conn qclean + return $ ConnRes conn myAuthCIDs reader -- | Creating a new socket and execute a path validation -- with a new connection ID. Typically, this is used diff --git a/Network/QUIC/Closer.hs b/Network/QUIC/Closer.hs --- a/Network/QUIC/Closer.hs +++ b/Network/QUIC/Closer.hs @@ -79,39 +79,46 @@ connected <- getSockConnected conn -- send let bufsiz = maximumUdpPayloadSize + -- Both buffers are taken before anything that can throw, and one action + -- frees them. They used to be taken either side of 'encodeCC' and + -- 'killReaders' with nothing to free them if those threw, and this runs + -- on the way out of every connection. sendbuf <- mallocBytes bufsiz - -- This must be called before freeResourcesin runClient. - siz <- encodeCC conn sendbuf bufsiz frame - let send - | connected = void $ NS.sendBuf sock sendbuf siz - | otherwise = void $ NS.sendBufTo sock sendbuf siz peersa - -- recv and clos - killReaders conn -- client only - (recv, freeRecvBuf, clos) <- + mrecvbuf <- if isServer conn - then return (void $ connRecv conn, free sendbuf, return ()) - else do - recvbuf <- mallocBytes bufsiz - let recv' - | connected = void $ NS.recvBuf sock recvbuf bufsiz - | otherwise = do - (_, sa) <- NS.recvBufFrom sock recvbuf bufsiz - when (sa /= peersa) recv' - free' = free recvbuf >> free sendbuf - clos' = do - NS.close sock - -- This is just in case. - getSocket conn >>= NS.close - return (recv', free', clos') - -- hook - let hook = onCloseCompleted $ connHooks conn - pto <- getPTO ldcc - void $ forkFinally (closer conn pto send recv hook) $ \e -> do - case e of - Left e' -> connDebugLog conn $ "closure' " <> bhow e' - Right _ -> return () - freeRecvBuf - clos + then return Nothing + else Just <$> mallocBytes bufsiz `E.onException` free sendbuf + let freeBufs = free sendbuf >> mapM_ free mrecvbuf + flip E.onException freeBufs $ do + -- This must be called before freeResourcesin runClient. + siz <- encodeCC conn sendbuf bufsiz frame + let send + | connected = void $ NS.sendBuf sock sendbuf siz + | otherwise = void $ NS.sendBufTo sock sendbuf siz peersa + -- recv and clos + killReaders conn -- client only + let (recv, clos) = case mrecvbuf of + Nothing -> (void $ connRecv conn, return ()) + Just recvbuf -> + let recv' + | connected = void $ NS.recvBuf sock recvbuf bufsiz + | otherwise = do + (_, sa) <- NS.recvBufFrom sock recvbuf bufsiz + when (sa /= peersa) recv' + clos' = do + NS.close sock + -- This is just in case. + getSocket conn >>= NS.close + in (recv', clos') + -- hook + let hook = onCloseCompleted $ connHooks conn + pto <- getPTO ldcc + void $ forkFinally (closer conn pto send recv hook) $ \e -> do + case e of + Left e' -> connDebugLog conn $ "closure' " <> bhow e' + Right _ -> return () + freeBufs + clos encodeCC :: Connection -> Buffer -> BufferSize -> Frame -> IO Int encodeCC conn sendbuf0 bufsiz0 frame = do diff --git a/Network/QUIC/Connection/Crypto.hs b/Network/QUIC/Connection/Crypto.hs --- a/Network/QUIC/Connection/Crypto.hs +++ b/Network/QUIC/Connection/Crypto.hs @@ -171,11 +171,11 @@ -- comes back from the same call as the ciphertext. ChaCha20-Poly1305 -- has no equivalent there and takes the path below. mgcm <- makeGcmEncrypt cipher txPayloadKey txPayloadIV txHeaderKey - (enc, set, get) <- case mgcm of + (enc, set, wmask) <- case mgcm of Just gcm -> return gcm Nothing -> do - (s', g') <- makeNiteProtector cipher txHeaderKey - return (makeNiteEncrypt cipher txPayloadKey txPayloadIV, s', g') + (s', w') <- makeNiteProtector cipher txHeaderKey + return (makeNiteEncrypt cipher txPayloadKey txPayloadIV, s', w') let dec = case makeGcmDecrypt cipher rxPayloadKey rxPayloadIV of Just d -> d Nothing -> makeNiteDecrypt cipher rxPayloadKey rxPayloadIV @@ -187,7 +187,7 @@ let protector = Protector { setSample = set - , getMask = get + , withMask = wmask , unprotect = unp } return (coder, protector) diff --git a/Network/QUIC/Connection/Types.hs b/Network/QUIC/Connection/Types.hs --- a/Network/QUIC/Connection/Types.hs +++ b/Network/QUIC/Connection/Types.hs @@ -154,7 +154,7 @@ data Protector = Protector { setSample :: Buffer -> IO () - , getMask :: IO Buffer + , withMask :: WithMask , unprotect :: Sample -> Mask } @@ -162,7 +162,7 @@ initialProtector = Protector { setSample = \_ -> return () - , getMask = return nullPtr + , withMask = \_ -> return False , unprotect = \_ -> Mask "" } diff --git a/Network/QUIC/Crypto/Nite.hs b/Network/QUIC/Crypto/Nite.hs --- a/Network/QUIC/Crypto/Nite.hs +++ b/Network/QUIC/Crypto/Nite.hs @@ -27,12 +27,15 @@ import qualified Data.ByteArray as Byte (ByteArrayAccess (..), convert) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS -import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, newForeignPtr_, withForeignPtr) -import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.ForeignPtr ( + ForeignPtr, + mallocForeignPtrBytes, + newForeignPtr_, + withForeignPtr, + ) import Foreign.Marshal.Utils (copyBytes) -import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) +import Foreign.Ptr (Ptr, castPtr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (peek, poke, pokeByteOff) -import Foreign.Ptr (castPtr) import Network.TLS hiding (Version) import qualified Network.TLS as TLS import Network.TLS.Extra.Cipher @@ -278,11 +281,11 @@ ---------------------------------------------------------------- -makeNiteProtector :: Cipher -> Key -> IO (Buffer -> IO (), IO Buffer) +makeNiteProtector :: Cipher -> Key -> IO (Buffer -> IO (), WithMask) makeNiteProtector cipher key = do ref <- newIORef nullPtr - dstbuf <- mallocBytes 32 -- fixme: free - return (niteSetSample ref, niteGetMask ref samplelen mkMask dstbuf) + dstfp <- mallocForeignPtrBytes 32 + return (niteSetSample ref, niteWithMask ref samplelen mkMask dstfp) where samplelen = 16 -- sampleLength cipher -- fixme mkMask = protectionMask cipher key @@ -290,15 +293,18 @@ niteSetSample :: IORef Buffer -> Buffer -> IO () niteSetSample = writeIORef -niteGetMask :: IORef Buffer -> Int -> (Sample -> Mask) -> Buffer -> IO Buffer -niteGetMask ref samplelen mkMask dstbuf = do +niteWithMask + :: IORef Buffer -> Int -> (Sample -> Mask) -> ForeignPtr Word8 -> WithMask +niteWithMask ref samplelen mkMask dstfp act = do srcbuf <- readIORef ref sample <- do fptr <- newForeignPtr_ srcbuf return $ PS fptr 0 samplelen let Mask mask = mkMask $ Sample sample - _len <- copyBS dstbuf mask - return dstbuf + withForeignPtr dstfp $ \dstbuf -> do + _len <- copyBS dstbuf mask + act dstbuf + return True ---------------------------------------------------------------- @@ -355,19 +361,21 @@ -- | The encryption side, with the mask. The two extra actions are the -- 'Protector' halves: they and the encryption share the buffer the mask is --- written to and the address the sample is taken from. +-- written to and the address the sample is taken from. The buffer is a +-- 'ForeignPtr' and is held only across the reader handed to 'WithMask', so +-- the collector frees it with the coder. makeGcmEncrypt :: Cipher -> Key -> IV -> Key - -> IO (Maybe (NiteEncrypt, Buffer -> IO (), IO Buffer)) + -> IO (Maybe (NiteEncrypt, Buffer -> IO (), WithMask)) makeGcmEncrypt cipher (Key key) iv (Key hpkey) = case gcmKeySize cipher of Nothing -> return Nothing Just _ -> case (mctx, mhk) of (Just ctx, Just hk) -> do ref <- newIORef nullPtr - maskBuf <- mallocBytes 16 -- fixme: free + maskfp <- mallocForeignPtrBytes 16 ivfp <- mallocForeignPtrBytes 12 noncefp <- mallocForeignPtrBytes 12 let IV ivbs = iv @@ -379,18 +387,20 @@ withForeignPtr ivfp $ \ivp -> writeNonce np ivp (fromIntegral pn) ok <- - GCM.encryptWithMask - ctx - hk - (NoncePtr noncefp) - ad - plaintext - 16 - off - dst - maskBuf + withForeignPtr maskfp $ \maskBuf -> + GCM.encryptWithMask + ctx + hk + (NoncePtr noncefp) + ad + plaintext + 16 + off + dst + maskBuf return $ if ok then BS.length plaintext + 16 else -1 - return $ Just (enc, writeIORef ref, return maskBuf) + gcmWithMask act = withForeignPtr maskfp act >> return True + return $ Just (enc, writeIORef ref, gcmWithMask) _ -> return Nothing where mctx = maybeCryptoError $ GCM.newContext key diff --git a/Network/QUIC/Crypto/Types.hs b/Network/QUIC/Crypto/Types.hs --- a/Network/QUIC/Crypto/Types.hs +++ b/Network/QUIC/Crypto/Types.hs @@ -9,6 +9,7 @@ AssDat (..), Sample (..), Mask (..), + WithMask, Nonce (..), Salt, Label (..), @@ -38,6 +39,22 @@ newtype Secret = Secret ScrubbedBytes deriving (Eq) newtype AssDat = AssDat ByteString deriving (Eq) newtype Sample = Sample ByteString deriving (Eq) + +-- | Running an action on the header protection mask, for as long as the +-- action takes and no longer. +-- +-- The mask lives in a buffer the encryption side owns, and the only way to +-- keep the garbage collector from taking that buffer out from under the +-- reader was to allocate it with 'mallocBytes' and never free it -- a leak +-- of 16 or 32 bytes for every coder, which is three to five per connection. +-- Handing the reader in instead of handing the buffer out lets the buffer +-- be a 'ForeignPtr' held across exactly the use, and the collector frees it +-- with the coder. +-- +-- 'False' when there is no mask to be had, which is a protector without +-- keys. +type WithMask = (Buffer -> IO ()) -> IO Bool + newtype Mask = Mask ByteString deriving (Eq) newtype Label = Label ByteString deriving (Eq) newtype Nonce = Nonce ByteString deriving (Eq) diff --git a/Network/QUIC/Logger.hs b/Network/QUIC/Logger.hs --- a/Network/QUIC/Logger.hs +++ b/Network/QUIC/Logger.hs @@ -1,13 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Logger ( Builder, DebugLogger, bhow, + dropIfUnwritable, stdoutLogger, dirDebugLogger, ) where +import qualified Control.Exception as E import Data.ByteString.Builder (byteString, toLazyByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as BL @@ -23,8 +26,32 @@ bhow :: Show a => a -> Builder bhow = byteString . C8.pack . show +-- | Running a write that describes a connection, dropping the message if +-- it cannot be written. Shared with the qlog writer, which is called +-- from the same threads and must be no more able to end them. +-- +-- A debug logger must not be able to end the connection it is describing. +-- It is called from the protocol threads, six of which run under nested +-- 'concurrently_' and take the rest down with them, so an exception from +-- the write ends the connection over a line of debug output. A daemon has +-- no stdout to write to -- it is closed, or a pipe whose reader has gone -- +-- and that is what mighty was doing with a debug directory set: +-- +-- debug: handshaker: \: hPutBuf: invalid argument (Bad file descriptor) +-- debug: handshaker: \: hPutBuf: resource vanished (Broken pipe) +-- +-- The peer saw a handshake that never finished, or, once a connection +-- ending of something in here said so, an INTERNAL_ERROR. It came and went +-- because a stdout that is not a terminal is block-buffered: most writes +-- only fill the buffer and it is the flush that fails. +-- +-- Only 'E.IOException' is dropped. An asynchronous exception is not one, +-- so cancelling a thread that is logging still cancels it. +dropIfUnwritable :: IO () -> IO () +dropIfUnwritable action = action `E.catch` \(_ :: E.IOException) -> return () + stdoutLogger :: DebugLogger -stdoutLogger b = BL.putStrLn $ toLazyByteString b +stdoutLogger b = dropIfUnwritable $ BL.putStrLn $ toLazyByteString b dirDebugLogger :: Maybe FilePath -> CID -> IO (DebugLogger, IO ()) dirDebugLogger Nothing _ = do @@ -35,6 +62,6 @@ let file = dir (show cid <> ".txt") (fastlogger, clean) <- newFastLogger1 (LogFileNoRotate file 4096) let dLog msg = do - fastlogger (toLogStr msg <> "\n") + dropIfUnwritable $ fastlogger (toLogStr msg <> "\n") stdoutLogger msg return (dLog, clean) diff --git a/Network/QUIC/Packet/Encode.hs b/Network/QUIC/Packet/Encode.hs --- a/Network/QUIC/Packet/Encode.hs +++ b/Network/QUIC/Packet/Encode.hs @@ -249,14 +249,15 @@ protector <- getProtector conn lvl setSample protector sampleBeg len <- encrypt coder cryptoBeg plaintext (AssDat header) pn - maskBeg <- getMask protector -- - if len < 0 || maskBeg == nullPtr + if len < 0 then return (-1, -1) else do - -- protecting header - protectHeader headerBeg pnBeg epnLen maskBeg - return (packetLen, padLen) + -- protecting header. The mask is read where it lives rather + -- than handed out, so the buffer holding it can be one the + -- garbage collector owns; 'False' is a protector without keys. + ok <- withMask protector $ protectHeader headerBeg pnBeg epnLen + return $ if ok then (packetLen, padLen) else (-1, -1) where calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz = do let headerLen = diff --git a/Network/QUIC/QLogger.hs b/Network/QUIC/QLogger.hs --- a/Network/QUIC/QLogger.hs +++ b/Network/QUIC/QLogger.hs @@ -5,6 +5,7 @@ dirQLogger, ) where +import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C8 import System.FilePath import System.Log.FastLogger @@ -30,5 +31,5 @@ dirQLogger (Just dir) tim cid rl = do let file = dir (show cid <> "-" <> C8.unpack rl <> ".qlog") (fastlogger, clean) <- newFastLogger1 $ LogFileNoRotate file 4096 - qlogger <- newQlogger tim rl cid fastlogger + qlogger <- newQlogger tim rl cid fastlogger `E.onException` clean return (qlogger, clean) diff --git a/Network/QUIC/Qlog.hs b/Network/QUIC/Qlog.hs --- a/Network/QUIC/Qlog.hs +++ b/Network/QUIC/Qlog.hs @@ -29,6 +29,7 @@ import Text.Printf import Network.QUIC.Imports +import Network.QUIC.Logger (dropIfUnwritable) import Network.QUIC.Parameters import Network.QUIC.Types @@ -331,22 +332,32 @@ type QLogger = QlogMsg -> IO () +-- | A qlog writer. +-- +-- The writes are dropped if they cannot be made, for the reason the debug +-- logger's are: this is called from the sender, the receiver and the +-- closer, which are protocol threads under nested 'concurrently_', so an +-- IOException from the write ends the connection the write was describing. +-- A qlog directory is asked for by name, as a debug directory is, and the +-- disk it is on can fill. A connection with a hole in its qlog is the +-- lesser of the two. newQlogger :: TimeMicrosecond -> ByteString -> CID -> FastLogger -> IO QLogger newQlogger base rl ocid fastLogger = do let ocid' = toLogStr $ enc16 $ fromCID ocid - fastLogger $ - "{\"qlog_format\":\"NDJSON\",\"qlog_version\":\"draft-02\",\"title\":\"Haskell quic qlog\",\"trace\":{\"vantage_point\":{\"type\":\"" - <> toLogStr rl - <> "\"},\"common_fields\":{\"ODCID\":\"" - <> ocid' - <> "\",\"group_id\":\"" - <> ocid' - <> "\",\"reference_time\":" - <> swtim base timeMicrosecond0 - <> "}}}\n" + dropIfUnwritable $ + fastLogger $ + "{\"qlog_format\":\"NDJSON\",\"qlog_version\":\"draft-02\",\"title\":\"Haskell quic qlog\",\"trace\":{\"vantage_point\":{\"type\":\"" + <> toLogStr rl + <> "\"},\"common_fields\":{\"ODCID\":\"" + <> ocid' + <> "\",\"group_id\":\"" + <> ocid' + <> "\",\"reference_time\":" + <> swtim base timeMicrosecond0 + <> "}}}\n" let qlogger qmsg = do let msg = toLogStrTime qmsg base - fastLogger msg + dropIfUnwritable $ fastLogger msg return qlogger ---------------------------------------------------------------- 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 @@ -56,16 +56,27 @@ check $ st == Stopped where debugLog _msg = return () + -- 'setup' is this bracket's acquire, so 'teardown' does not run when it + -- throws -- and it does throw: a server given two addresses whose second + -- port is taken leaves the first socket bound and the token manager + -- thread running, for good. Each step frees what the steps before it + -- took, which for a list means each element frees itself. setup stvar = do dispatch <- newDispatch conf let forkConn acc = void $ forkIO (runServer conf server dispatch stvar acc) - ssas <- mapM serverSocket $ scAddresses conf - tids <- mapM (runDispatcher dispatch conf stvar forkConn) ssas - return (dispatch, tids, ssas) + flip E.onException (clearDispatch dispatch) $ do + ssas <- openAll $ scAddresses conf + tids <- + runAll dispatch conf stvar forkConn ssas + `E.onException` mapM_ NS.close ssas + return (dispatch, tids, ssas) teardown (dispatch, tids, ssas) = do clearDispatch dispatch mapM_ killThread tids mapM_ NS.close ssas + openAll [] = return [] + openAll (a : as) = + E.bracketOnError (serverSocket a) NS.close $ \s -> (s :) <$> openAll as -- | Running a QUIC server. -- The action is executed with a new connection @@ -82,15 +93,32 @@ check $ st == Stopped where debugLog _msg = return () + -- As in 'run'. The sockets are the caller's here, so only the token + -- manager and the dispatchers are ours to free. setup stvar = do dispatch <- newDispatch conf let forkConn acc = void $ forkIO (runServer conf server dispatch stvar acc) - tids <- mapM (runDispatcher dispatch conf stvar forkConn) ssas - return (dispatch, tids) + flip E.onException (clearDispatch dispatch) $ do + tids <- runAll dispatch conf stvar forkConn ssas + return (dispatch, tids) teardown (dispatch, tids) = do clearDispatch dispatch mapM_ killThread tids +-- | Running a dispatcher on each socket, killing the ones already running if +-- a later one cannot be started. +runAll + :: Dispatch + -> ServerConfig + -> TVar ServerState + -> (Accept -> IO ()) + -> [NS.Socket] + -> IO [ThreadId] +runAll _ _ _ _ [] = return [] +runAll dispatch conf stvar forkConn (s : ss) = + E.bracketOnError (runDispatcher dispatch conf stvar forkConn s) killThread $ + \t -> (t :) <$> runAll dispatch conf stvar forkConn ss + -- Typically, ConnectionIsClosed breaks acceptStream. -- And the exception should be ignored. runServer @@ -211,65 +239,78 @@ recv = recvServer accRecvQ let myCID = fromJust $ initSrcCID accMyAuthCIDs ocid = fromJust $ origDstCID accMyAuthCIDs - (qLog, qclean) <- dirQLogger scQLog accTime ocid "server" - (debugLog, dclean) <- dirDebugLogger scDebugLog ocid - debugLog $ "Original CID: " <> bhow ocid - connRecvDatagramQ <- newTQueueIO - conn <- - serverConnection - conf - accVersionInfo - accMyAuthCIDs - accPeerAuthCIDs - debugLog - qLog - scHooks - sref - piref - accRecvQ - connRecvDatagramQ - send - recv - (genStatelessReset dispatch) - addResource conn qclean - addResource conn dclean - let cid = fromMaybe ocid $ retrySrcCID accMyAuthCIDs - ver = chosenVersion accVersionInfo - initializeCoder conn InitialLevel $ initialSecrets ver cid - setupCryptoStreams conn -- fixme: cleanup - let peersa = accPeerSockAddr - -- RFC9000 \S14.2 - -- "In the absence of these mechanisms, QUIC endpoints SHOULD - -- NOT send datagrams larger than the smallest allowed maximum - -- datagram size." - -- - -- Thus use 1200 bytes for minimum packet size. - pktSiz = - (defaultQUICPacketSize `max` accPacketSize) - `min` maximumPacketSize peersa - setMaxPacketSize conn pktSiz - setInitialCongestionWindow (connLDCC conn) pktSiz - debugLog $ "Packet size: " <> bhow pktSiz <> " (" <> bhow accPacketSize <> ")" - when accAddressValidated $ setAddressValidated pathInfo - -- - let retried = isJust $ retrySrcCID accMyAuthCIDs - when retried $ do - qlogRecvInitial conn - qlogSentRetry conn - -- - let mgr = tokenMgr dispatch - setTokenManager conn mgr - -- - setStopServer conn $ atomically $ writeTVar stvar Stopped - -- - setRegister conn accRegister accUnregister - accRegister myCID conn - addResource conn $ do - myCIDs <- getMyCIDs conn - mapM_ accUnregister myCIDs - + -- Nothing here is under 'runServer's bracket: that bracket's acquire is + -- this function, so whatever it has taken when it throws is released by + -- nobody. It was taking two log files, three 2048-byte buffers and a + -- registration in the dispatcher, and a connection setup does fail -- + -- 'dirQLogger' says how, and that is what it was doing in the field. -- - return $ ConnRes conn accMyAuthCIDs undefined + -- One releaser is in force at a time. The logs stay this function's own + -- until the end and are handed to the connection only once nothing is + -- left that can throw, so 'freeResources' and the handlers here never + -- both close the same thing. + (qLog, qclean) <- dirQLogger scQLog accTime ocid "server" + (debugLog, dclean) <- dirDebugLogger scDebugLog ocid `E.onException` qclean + flip E.onException (dclean >> qclean) $ do + debugLog $ "Original CID: " <> bhow ocid + connRecvDatagramQ <- newTQueueIO + conn <- + serverConnection + conf + accVersionInfo + accMyAuthCIDs + accPeerAuthCIDs + debugLog + qLog + scHooks + sref + piref + accRecvQ + connRecvDatagramQ + send + recv + (genStatelessReset dispatch) + flip E.onException (setDead conn >> freeResources conn) $ do + let cid = fromMaybe ocid $ retrySrcCID accMyAuthCIDs + ver = chosenVersion accVersionInfo + initializeCoder conn InitialLevel $ initialSecrets ver cid + setupCryptoStreams conn -- fixme: cleanup + let peersa = accPeerSockAddr + -- RFC9000 \S14.2 + -- "In the absence of these mechanisms, QUIC endpoints SHOULD + -- NOT send datagrams larger than the smallest allowed maximum + -- datagram size." + -- + -- Thus use 1200 bytes for minimum packet size. + pktSiz = + (defaultQUICPacketSize `max` accPacketSize) + `min` maximumPacketSize peersa + setMaxPacketSize conn pktSiz + setInitialCongestionWindow (connLDCC conn) pktSiz + debugLog $ "Packet size: " <> bhow pktSiz <> " (" <> bhow accPacketSize <> ")" + when accAddressValidated $ setAddressValidated pathInfo + -- + let retried = isJust $ retrySrcCID accMyAuthCIDs + when retried $ do + qlogRecvInitial conn + qlogSentRetry conn + -- + let mgr = tokenMgr dispatch + setTokenManager conn mgr + -- + setStopServer conn $ atomically $ writeTVar stvar Stopped + -- + setRegister conn accRegister accUnregister + accRegister myCID conn + addResource conn $ do + myCIDs <- getMyCIDs conn + mapM_ accUnregister myCIDs + -- Handing the logs over. Nothing below can throw, so from here + -- 'freeResources' is the only releaser and the handlers above + -- have nothing left to free. + addResource conn qclean + addResource conn dclean + return $ ConnRes conn accMyAuthCIDs undefined afterHandshakeServer :: ServerConfig -> Connection -> IO () afterHandshakeServer ServerConfig{..} conn = handleLogT logAction $ do diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic -version: 0.3.12 +version: 0.3.13 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -232,12 +232,14 @@ FrameSpec HandshakeSpec IOSpec + LoggerSpec PacketSpec ReassSpec ParametersSpec QLoggerSpec RecoverySpec ResetSpec + SetupSpec TLSSpec TokenSpec TransportError @@ -260,6 +262,7 @@ crypto-token, crypton, directory, + fast-logger >=3.2.2 && <3.3, filepath, hspec, network >=3.2.2, diff --git a/test/LoggerSpec.hs b/test/LoggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/LoggerSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LoggerSpec where + +import qualified Control.Exception as E +import Control.Monad (when) +import Data.IORef +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.Directory +import System.FilePath +import System.IO +import System.Log.FastLogger (FastLogger) +import Test.Hspec + +import Network.QUIC.Internal + +spec :: Spec +spec = do + -- A debug logger is called from the protocol threads, six of which run + -- under nested concurrently_ and take the rest down with them, so a + -- write that throws ends the connection it was describing. A daemon + -- has no stdout to write to: mighty's connections were ending on + -- + -- debug: handshaker: : hPutBuf: invalid argument + -- (Bad file descriptor) + -- + -- and the peer saw a handshake that never finished. + describe "stdoutLogger" $ + it "drops a message stdout cannot take" $ + withUnwritableStdout (stdoutLogger "a line no one can receive") + `shouldReturn` () + + describe "dirDebugLogger" $ + -- The file is what the caller asked for, and it is still written + -- when stdout is gone. + it "writes the file when stdout cannot be written" $ + withDebugDir $ \dir -> do + (dLog, clean) <- dirDebugLogger (Just dir) cid + withUnwritableStdout $ dLog "a line the file can take" + clean + readFile (dir show cid <> ".txt") + `shouldReturn` "a line the file can take\n" + -- The qlog writer is called from the sender, the receiver and the + -- closer, the same protocol threads as the debug logger, so it must be + -- no more able to end them. A qlog directory is asked for by name, as + -- a debug directory is, and the disk it is on can fill. + describe "newQlogger" $ do + it "does not throw when the header cannot be written" $ do + tim <- getTimeMicrosecond + _ <- newQlogger tim "server" cid full + return () + + it "drops a message that cannot be written" $ do + tim <- getTimeMicrosecond + qlogger <- newQlogger tim "server" cid full + qlogger (QDebug "a line the disk has no room for" tim) + `shouldReturn` () + + -- Only an IOException is dropped. Nothing else is, and an + -- asynchronous exception is not one, so cancelling a thread that is + -- writing a qlog still cancels it. + it "lets anything that is not an IOException through" $ do + tim <- getTimeMicrosecond + -- The header is the first write, and it has to get through for + -- there to be a logger to try. + afterTheHeader <- brokenAfter 1 + qlogger <- newQlogger tim "server" cid afterTheHeader + qlogger (QDebug "not the disk's fault" tim) + `shouldThrow` errorCall "boom" + where + full :: FastLogger + full _ = E.throwIO $ userError "no space left on device" + brokenAfter :: Int -> IO FastLogger + brokenAfter k = do + ref <- newIORef (0 :: Int) + return $ \_ -> do + n <- atomicModifyIORef' ref $ \x -> (x + 1, x) + when (n >= k) $ E.throwIO $ E.ErrorCall "boom" + cid = makeCID "\x01\x02\x03\x04\x05\x06\x07\x08" + +-- | Running an action with a stdout every write throws on, and putting the +-- real one back afterwards. stdout is redirected rather than closed: +-- hspec reports through it, and a handle that is only redirected can be +-- restored from the duplicate however the action ends. +withUnwritableStdout :: IO a -> IO a +withUnwritableStdout action = do + saved <- hDuplicate stdout + let redirected = withFile "/dev/null" ReadMode $ \h -> do + hDuplicateTo h stdout + action `E.finally` hDuplicateTo saved stdout + redirected `E.finally` hClose saved + +withDebugDir :: (FilePath -> IO a) -> IO a +withDebugDir = E.bracket newDir removePathForcibly + where + newDir = do + tmp <- getTemporaryDirectory + let dir = tmp "quic-logger-spec" + removePathForcibly dir + createDirectory dir + return dir diff --git a/test/SetupSpec.hs b/test/SetupSpec.hs new file mode 100644 --- /dev/null +++ b/test/SetupSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | What a connection or a server setup leaves behind when it fails. +-- +-- 'createServerConnection' and 'run's own @setup@ are the acquire of their +-- bracket, so the release does not run when they throw and whatever they +-- have taken is freed by nobody. +-- +-- Only the first has a test here. What @setup@ leaks is a bound UDP socket, +-- and whether a port is still taken is not a portable question: on Linux two +-- UDP sockets with SO_REUSEADDR may hold the same address and port at once, +-- so the bind that is supposed to fail succeeds and the bind that is +-- supposed to succeed says nothing about the leak. A first attempt at it +-- hung every CI job on the former. +module SetupSpec where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import qualified Control.Exception as E +import System.Directory +import System.FilePath +import System.IO +import Test.Hspec + +import Network.QUIC +import qualified Network.QUIC.Client as C +import Network.QUIC.Internal +import Network.QUIC.Server + +import Config + +spec :: Spec +spec = do + -- The qlog is opened before the debug log, and a debug log that cannot + -- be opened is a real failure: a directory that is not there, or the + -- "openFile: resource busy" of a client and a server in one process + -- pointed at one directory. + describe "a server connection setup that fails" $ + it "does not leave the qlog it had already opened open" $ + withTempDir $ \dir -> do + let qdir = dir "qlog" + createDirectory qdir + sc0 <- makeTestServerConfig + let sc = + sc0 + { scQLog = Just qdir + , scDebugLog = Just (dir "not-a-directory") + } + cc = + testClientConfig + { ccParameters = + (ccParameters testClientConfig) + { maxIdleTimeout = Milliseconds 1000 + } + } + withAsync (run sc $ \_ -> return ()) $ \_ -> + C.run cc (\_ -> return ()) + `shouldThrow` (\(_ :: QUICException) -> True) + -- If the handle is still open, GHC's own lock on the file + -- says so. + files <- listDirectory qdir + files `shouldNotSatisfy` null + mapM_ (waitUnlocked . (qdir )) files + +-- | Waiting for a file to come unlocked, which is to say for the handle on +-- it to be closed. +-- +-- The server forks a connection for each Initial it cannot place, and a +-- client that hears nothing retransmits, so when the client gives up there +-- may be an attempt still on its way out holding the file. Taking that for +-- a leak would be a test that fails when the machine is busy; a leaked +-- handle, on the other hand, is held for the life of the process, so +-- waiting tells the two apart. +waitUnlocked :: FilePath -> IO () +waitUnlocked file = go (100 :: Int) + where + open = withFile file WriteMode $ \_ -> return () + go 0 = open -- out of patience: let the lock speak for itself + go n = do + r <- E.try open + case r of + Right () -> return () + Left (_ :: E.IOException) -> threadDelay 20000 >> go (n - 1) + +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir = E.bracket newDir removePathForcibly + where + newDir = do + tmp <- getTemporaryDirectory + let dir = tmp "quic-setup-spec" + removePathForcibly dir + createDirectory dir + return dir