quic 0.3.12 → 0.3.13

raw patch · 15 files changed

+589/−210 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +57/−0
• Network/QUIC/Client/Run.hs +74/−65
• Network/QUIC/Closer.hs +38/−31
• Network/QUIC/Connection/Crypto.hs +4/−4
• Network/QUIC/Connection/Types.hs +2/−2
• Network/QUIC/Crypto/Nite.hs +35/−25
• Network/QUIC/Crypto/Types.hs +17/−0
• Network/QUIC/Logger.hs +29/−2
• Network/QUIC/Packet/Encode.hs +6/−5
• Network/QUIC/QLogger.hs +2/−1
• Network/QUIC/Qlog.hs +22/−11
• Network/QUIC/Server/Run.hs +104/−63
• quic.cabal +4/−1
• test/LoggerSpec.hs +101/−0
• test/SetupSpec.hs +94/−0

@@ -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,

@@ -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

@@ -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

@@ -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)

@@ -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 ""         } 

@@ -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

@@ -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)

@@ -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: \<stdout\>: hPutBuf: invalid argument (Bad file descriptor)+--   debug: handshaker: \<stdout\>: 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)

@@ -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 =

@@ -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)

@@ -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  ----------------------------------------------------------------

@@ -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

@@ -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,

@@ -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: <stdout>: 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

@@ -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