diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for http3 +## 0.0.19 + +* Labeling threads. +* Removing `unliftio`. +* Using `http-semantics` v0.3. + ## 0.0.18 * Using http-semantics v0.2.1 diff --git a/Network/HQ/Client.hs b/Network/HQ/Client.hs --- a/Network/HQ/Client.hs +++ b/Network/HQ/Client.hs @@ -31,6 +31,7 @@ getResponseBodyChunk, ) where +import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.IORef import Network.HPACK @@ -40,7 +41,6 @@ import Network.QUIC (Connection) import qualified Network.QUIC as QUIC import Network.QUIC.Internal (possibleMyStreams) -import qualified UnliftIO.Exception as E import Imports import qualified Network.HTTP3.Client as H3 diff --git a/Network/HQ/Server.hs b/Network/HQ/Server.hs --- a/Network/HQ/Server.hs +++ b/Network/HQ/Server.hs @@ -37,6 +37,7 @@ import qualified Data.ByteString.Internal as BS import Data.IORef import Foreign.ForeignPtr +import GHC.Conc.Sync import Network.HPACK.Internal (toTokenHeaderTable) import Network.HTTP.Semantics.IO import Network.HTTP.Semantics.Server @@ -61,9 +62,14 @@ forever $ do strm <- QUIC.acceptStream conn forkFinally - (processRequest conf mysa peersa server strm) + (labelMe "H3 processRequest" >> processRequest conf mysa peersa server strm) (\_ -> QUIC.closeStream strm) +labelMe :: String -> IO () +labelMe label = do + tid <- myThreadId + labelThread tid label + processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO () processRequest conf mysa peersa server strm | QUIC.isClientInitiatedBidirectional sid = do @@ -107,14 +113,8 @@ sendResponse conf strm (Response outobj) _ = case outObjBody outobj of OutBodyNone -> return () OutBodyFile (FileSpec path fileoff bytecount) -> do - (pread, sentinel') <- confPositionReadMaker conf path - let timmgr = confTimeoutManager conf - refresh <- case sentinel' of - Closer closer -> do - th <- T.register timmgr closer - return $ T.tickle th - Refresher refresher -> return refresher - let next = fillFileBodyGetNext pread fileoff bytecount refresh + (pread, sentinel) <- confPositionReadMaker conf path + let next = fillFileBodyGetNext pread fileoff bytecount sentinel sendNext strm next OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder diff --git a/Network/HTTP3/Client.hs b/Network/HTTP3/Client.hs --- a/Network/HTTP3/Client.hs +++ b/Network/HTTP3/Client.hs @@ -18,6 +18,7 @@ ) where import Control.Concurrent +import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C8 import Data.IORef import Network.HTTP.Semantics.Client @@ -25,7 +26,6 @@ import Network.QUIC (Connection) import qualified Network.QUIC as QUIC import Network.QUIC.Internal (possibleMyStreams) -import qualified UnliftIO.Exception as E import Imports import Network.HTTP3.Config diff --git a/Network/HTTP3/Context.hs b/Network/HTTP3/Context.hs --- a/Network/HTTP3/Context.hs +++ b/Network/HTTP3/Context.hs @@ -25,6 +25,7 @@ ) where import Control.Concurrent +import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.IORef import Network.HTTP.Semantics.Client @@ -33,7 +34,6 @@ import Network.Socket (SockAddr) import System.Mem.Weak import qualified System.TimeManager as T -import qualified UnliftIO.Exception as E import Network.HTTP3.Config import Network.HTTP3.Stream @@ -58,8 +58,8 @@ (enc, handleDI) <- newQEncoder defaultQEncoderConfig (dec, handleEI) <- newQDecoder defaultQDecoderConfig info <- getConnectionInfo conn - let handleDI' recv = handleDI recv `E.catchAny` abortWith QpackDecoderStreamError - handleEI' recv = handleEI recv `E.catchAny` abortWith QpackEncoderStreamError + let handleDI' recv = handleDI recv `E.catch` abortWith QpackDecoderStreamError + handleEI' recv = handleEI recv `E.catch` abortWith QpackEncoderStreamError sw = switch conn ctl handleEI' handleDI' preadM = confPositionReadMaker conf timmgr = confTimeoutManager conf @@ -68,7 +68,9 @@ peersa = remoteSockAddr info Context conn enc dec sw preadM timmgr hooks mysa peersa <$> newIORef [] where - abortWith aerr _se = abortConnection conn aerr "" + abortWith aerr se + | Just E.ThreadKilled <- E.fromException se = return () + | otherwise = abortConnection conn aerr "" clearContext :: Context -> IO () clearContext ctx = clearThreads ctx diff --git a/Network/HTTP3/Send.hs b/Network/HTTP3/Send.hs --- a/Network/HTTP3/Send.hs +++ b/Network/HTTP3/Send.hs @@ -6,6 +6,7 @@ sendBody, ) where +import qualified Control.Exception as E import qualified Data.ByteString.Builder.Extra as B import qualified Data.ByteString.Internal as BS import Data.IORef @@ -16,7 +17,6 @@ import qualified Network.HTTP.Types as HT import Network.QUIC import qualified System.TimeManager as T -import qualified UnliftIO.Exception as E import Imports import Network.HTTP3.Context @@ -37,11 +37,8 @@ sendBody ctx strm th outobj = case outObjBody outobj of OutBodyNone -> return () OutBodyFile (FileSpec path fileoff bytecount) -> do - (pread, sentinel') <- pReadMaker ctx path - refresh <- case sentinel' of - Closer closer -> timeoutClose ctx closer - Refresher refresher -> return refresher - let next = fillFileBodyGetNext pread fileoff bytecount refresh + (pread, sentinel) <- pReadMaker ctx path + let next = fillFileBodyGetNext pread fileoff bytecount sentinel sendNext ctx strm th next tlrmkr OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder diff --git a/Network/HTTP3/Server.hs b/Network/HTTP3/Server.hs --- a/Network/HTTP3/Server.hs +++ b/Network/HTTP3/Server.hs @@ -22,7 +22,9 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM +import qualified Control.Exception as E import Data.IORef +import GHC.Conc.Sync import Network.HTTP.Semantics import Network.HTTP.Semantics.Server import Network.HTTP.Semantics.Server.Internal @@ -30,7 +32,6 @@ import Network.QUIC (Connection, ConnectionInfo (..), Stream, getConnectionInfo) import qualified Network.QUIC as QUIC import qualified System.TimeManager as T -import qualified UnliftIO.Exception as E import Imports import Network.HTTP3.Config @@ -45,7 +46,9 @@ -- | Running an HTTP\/3 server. run :: Connection -> Config -> Server -> IO () run conn conf server = E.bracket open close $ \ctx -> do + myThreadId >>= \t -> labelThread t "H3 run" tid <- forkIO $ setupUnidirectional conn conf + labelThread tid "H3 unidirectional setter" addThreadId ctx tid readerServer ctx $ \strm -> void $ @@ -61,6 +64,7 @@ runIO :: Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO () runIO conn conf action = E.bracket open close $ \ctx -> do tid <- forkIO $ setupUnidirectional conn conf + labelThread tid "H3 unidirectional setter" info <- getConnectionInfo conn addThreadId ctx tid reqq <- newTQueueIO @@ -88,7 +92,10 @@ loop process strm | QUIC.isClientInitiatedUnidirectional sid = do - tid <- forkIO $ unidirectional ctx strm + tid <- forkIO $ do + tid <- myThreadId + labelThread tid "H3 unidirectional handler" + unidirectional ctx strm addThreadId ctx tid | QUIC.isClientInitiatedBidirectional sid = action strm | QUIC.isServerInitiatedUnidirectional sid = return () -- error @@ -97,7 +104,9 @@ sid = QUIC.streamId strm processRequest :: Context -> Server -> Stream -> IO () -processRequest ctx server strm = E.handleAny reset $ do +processRequest ctx server strm = E.handle reset $ do + tid <- myThreadId + labelThread tid "H3 processRequest" th <- registerThread ctx src <- newSource strm mvt <- recvHeader ctx src @@ -109,12 +118,13 @@ server req aux $ sendResponse ctx strm th where reset se + | Just E.ThreadKilled <- E.fromException se = return () | Just (_ :: DecodeError) <- E.fromException se = abort ctx QpackDecompressionFailed | otherwise = QUIC.resetStream strm H3MessageError processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO () -processRequestIO ctx put strm = E.handleAny reset $ do +processRequestIO ctx put strm = E.handle reset $ do src <- newSource strm mvt <- recvHeader ctx src case mvt of @@ -124,6 +134,7 @@ put (strm, req) where reset se + | Just E.ThreadKilled <- E.fromException se = return () | Just (_ :: DecodeError) <- E.fromException se = abort ctx QpackDecompressionFailed | otherwise = QUIC.resetStream strm H3MessageError diff --git a/Network/QPACK.hs b/Network/QPACK.hs --- a/Network/QPACK.hs +++ b/Network/QPACK.hs @@ -46,6 +46,7 @@ import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception as E import qualified Data.ByteString as B import Data.CaseInsensitive import Network.ByteOrder @@ -58,7 +59,6 @@ ) import Network.HTTP.Types import Network.QUIC.Internal (stdoutLogger) -import qualified UnliftIO.Exception as E import Imports import Network.QPACK.Error diff --git a/Network/QPACK/Error.hs b/Network/QPACK/Error.hs --- a/Network/QPACK/Error.hs +++ b/Network/QPACK/Error.hs @@ -12,8 +12,8 @@ DecoderInstructionError (..), ) where +import Control.Exception import Data.Typeable -import UnliftIO.Exception import Network.QUIC diff --git a/Network/QPACK/HeaderBlock/Encode.hs b/Network/QPACK/HeaderBlock/Encode.hs --- a/Network/QPACK/HeaderBlock/Encode.hs +++ b/Network/QPACK/HeaderBlock/Encode.hs @@ -10,6 +10,7 @@ CompressionAlgo (..), ) where +import qualified Control.Exception as E import qualified Data.ByteString as B import Data.IORef import Network.ByteOrder @@ -22,7 +23,6 @@ ) import Network.HTTP.Semantics import Network.HTTP.Types -import qualified UnliftIO.Exception as E import Imports import Network.QPACK.HeaderBlock.Prefix diff --git a/Network/QPACK/HeaderBlock/Prefix.hs b/Network/QPACK/HeaderBlock/Prefix.hs --- a/Network/QPACK/HeaderBlock/Prefix.hs +++ b/Network/QPACK/HeaderBlock/Prefix.hs @@ -10,9 +10,9 @@ decodeBase, ) where +import qualified Control.Exception as E import Network.ByteOrder import Network.HPACK.Internal (decodeI, encodeI) -import qualified UnliftIO.Exception as E import Imports import Network.QPACK.Error @@ -40,9 +40,9 @@ decodeRequiredInsertCount :: Int -> InsertionPoint -> Int -> InsertionPoint decodeRequiredInsertCount _ _ 0 = 0 decodeRequiredInsertCount maxEntries (InsertionPoint totalNumberOfInserts) encodedInsertCount - | encodedInsertCount > fullRange = E.impureThrow IllegalInsertCount + | encodedInsertCount > fullRange = E.throw IllegalInsertCount | reqInsertCount > maxValue && reqInsertCount <= fullRange = - E.impureThrow IllegalInsertCount + E.throw IllegalInsertCount | reqInsertCount > maxValue = InsertionPoint (reqInsertCount - fullRange) | otherwise = InsertionPoint reqInsertCount where diff --git a/Network/QPACK/Instruction.hs b/Network/QPACK/Instruction.hs --- a/Network/QPACK/Instruction.hs +++ b/Network/QPACK/Instruction.hs @@ -20,6 +20,7 @@ decodeDI, ) where +import qualified Control.Exception as E import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive import Network.ByteOrder @@ -32,7 +33,6 @@ encodeS, entryHeaderName, ) -import qualified UnliftIO.Exception as E import Imports import Network.QPACK.Table.Static diff --git a/Network/QPACK/Table/Dynamic.hs b/Network/QPACK/Table/Dynamic.hs --- a/Network/QPACK/Table/Dynamic.hs +++ b/Network/QPACK/Table/Dynamic.hs @@ -4,6 +4,7 @@ module Network.QPACK.Table.Dynamic where import Control.Concurrent.STM +import qualified Control.Exception as E import Data.Array.Base (unsafeRead, unsafeWrite) import Data.Array.MArray (newArray) import Data.IORef @@ -18,7 +19,6 @@ dummyEntry, maxNumbers, ) -import qualified UnliftIO.Exception as E import Imports import Network.QPACK.Table.RevIndex diff --git a/Network/QPACK/Table/Static.hs b/Network/QPACK/Table/Static.hs --- a/Network/QPACK/Table/Static.hs +++ b/Network/QPACK/Table/Static.hs @@ -6,11 +6,11 @@ staticTableList, ) where +import qualified Control.Exception as E import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Internal (Entry, Index, Size, toEntry) import Network.HTTP.Types (Header) -import qualified UnliftIO.Exception as E import Network.QPACK.Error import Network.QPACK.Types @@ -34,7 +34,7 @@ toStaticEntry :: AbsoluteIndex -> Entry toStaticEntry (AbsoluteIndex sidx) | sidx < staticTableSize = staticTable `unsafeAt` sidx - | otherwise = E.impureThrow IllegalStaticIndex + | otherwise = E.throw IllegalStaticIndex -- | Pre-defined static table. staticTable :: Array Index Entry diff --git a/http3.cabal b/http3.cabal --- a/http3.cabal +++ b/http3.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: http3 -version: 0.0.18 +version: 0.0.19 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto @@ -82,7 +82,7 @@ bytestring, case-insensitive, containers, - http-semantics >= 0.2.1 && <0.3, + http-semantics >= 0.3 && <0.4, http-types, http2 >=5.3.4 && <5.4, network, @@ -90,8 +90,7 @@ quic >= 0.2 && < 0.3, sockaddr, stm, - time-manager, - unliftio + time-manager executable h3-server main-is: h3-server.hs @@ -114,8 +113,7 @@ http3, quic, tls < 2.2, - tls-session-manager, - unliftio + tls-session-manager if flag(devel) @@ -142,8 +140,7 @@ http3, quic, tls, - unix-time, - unliftio + unix-time if flag(devel) @@ -164,8 +161,7 @@ conduit-extra, http3, quic, - stm, - unliftio + stm if flag(devel) @@ -194,6 +190,7 @@ base >=4.9 && <5, QuickCheck, attoparsec, + async, base16-bytestring, bytestring, conduit, @@ -208,5 +205,4 @@ network, quic, stm, - tls, - unliftio + tls diff --git a/test/HTTP3/Error.hs b/test/HTTP3/Error.hs --- a/test/HTTP3/Error.hs +++ b/test/HTTP3/Error.hs @@ -6,6 +6,7 @@ ) where import Control.Concurrent +import qualified Control.Exception as E import Data.ByteString () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 @@ -16,9 +17,8 @@ import Network.QUIC import Network.QUIC.Client import Network.QUIC.Internal hiding (timeout) +import System.Timeout import Test.Hspec -import qualified UnliftIO.Exception as E -import UnliftIO.Timeout ---------------------------------------------------------------- diff --git a/test/HTTP3/Server.hs b/test/HTTP3/Server.hs --- a/test/HTTP3/Server.hs +++ b/test/HTTP3/Server.hs @@ -10,8 +10,11 @@ ) where import Control.Concurrent +-- cryptonite + +import qualified Control.Exception as E import Control.Monad -import Crypto.Hash (Context, SHA1) -- cryptonite +import Crypto.Hash (Context, SHA1) import qualified Crypto.Hash as CH import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -24,7 +27,6 @@ import qualified Network.QUIC.Server as QUIC import Network.Socket () import Test.Hspec -import qualified UnliftIO.Exception as E import HTTP3.Config diff --git a/test/HTTP3/ServerSpec.hs b/test/HTTP3/ServerSpec.hs --- a/test/HTTP3/ServerSpec.hs +++ b/test/HTTP3/ServerSpec.hs @@ -3,6 +3,8 @@ module HTTP3.ServerSpec where +import Control.Concurrent.Async +import qualified Control.Exception as E import Control.Monad import qualified Data.ByteString as B import Network.HTTP.Types @@ -10,8 +12,6 @@ import Network.HTTP3.Server import qualified Network.QUIC.Client as QUIC import Test.Hspec -import UnliftIO.Async -import qualified UnliftIO.Exception as E import HTTP3.Config import HTTP3.Server diff --git a/test/QPACK/QIFSpec.hs b/test/QPACK/QIFSpec.hs --- a/test/QPACK/QIFSpec.hs +++ b/test/QPACK/QIFSpec.hs @@ -6,6 +6,7 @@ import Conduit hiding (yield) import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception as E import Control.Monad import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P @@ -15,7 +16,6 @@ import Data.Conduit.Attoparsec import System.IO import Test.Hspec -import qualified UnliftIO.Exception as E import Network.QPACK diff --git a/util/ClientX.hs b/util/ClientX.hs --- a/util/ClientX.hs +++ b/util/ClientX.hs @@ -11,12 +11,12 @@ import Control.Concurrent import Control.Concurrent.Async +import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Types import Network.QUIC -import qualified UnliftIO.Exception as E import qualified Network.HQ.Client as HQ import Network.HTTP3.Client ( diff --git a/util/ServerX.hs b/util/ServerX.hs --- a/util/ServerX.hs +++ b/util/ServerX.hs @@ -6,8 +6,11 @@ ) where +-- crypton + +import qualified Control.Exception as E import Control.Monad -import Crypto.Hash (Context, SHA1) -- crypton +import Crypto.Hash (Context, SHA1) import qualified Crypto.Hash as CH import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -17,7 +20,6 @@ import Network.HTTP.Types import Network.HTTP2.Server hiding (run) import qualified Network.HTTP3.Server as H3 -import qualified UnliftIO.Exception as E import Network.QUIC diff --git a/util/h3-client.hs b/util/h3-client.hs --- a/util/h3-client.hs +++ b/util/h3-client.hs @@ -17,8 +17,8 @@ import System.Environment import System.Exit import System.IO +import qualified System.Timeout as T import Text.Printf -import qualified UnliftIO.Timeout as T import ClientX import Common @@ -193,8 +193,8 @@ args <- getArgs (opts@Options{..}, ips) <- clientOpts args (host, port, paths) <- case ips of - [] -> showUsageAndExit usage - _ : [] -> showUsageAndExit usage + [] -> showUsageAndExit "no args" + _ : [] -> showUsageAndExit "N of args must be 2 or larger" h : p : [] -> return (h, p, ["/"]) h : p : ps -> return (h, p, C8.pack <$> ps) cmvar <- newEmptyMVar diff --git a/util/qif.hs b/util/qif.hs --- a/util/qif.hs +++ b/util/qif.hs @@ -6,6 +6,7 @@ import Conduit hiding (yield) import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception as E import Control.Monad import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P @@ -15,7 +16,6 @@ import Data.Conduit.Attoparsec import System.Environment import System.IO -import qualified UnliftIO.Exception as E import Network.QPACK