http3 0.0.6 → 0.0.7
raw patch · 38 files changed
+2061/−1598 lines, 38 filesdep ~http2dep ~quicPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: http2, quic
API changes (from Hackage documentation)
- Network.HQ.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> IO a
+ Network.HQ.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> Aux -> IO a
- Network.HTTP3.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> IO a
+ Network.HTTP3.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> Aux -> IO a
Files
- ChangeLog.md +4/−0
- Network/HQ/Client.hs +35/−24
- Network/HQ/Server.hs +65/−57
- Network/HTTP3/Client.hs +91/−75
- Network/HTTP3/Config.hs +20/−19
- Network/HTTP3/Context.hs +50/−44
- Network/HTTP3/Control.hs +49/−46
- Network/HTTP3/Error.hs +22/−19
- Network/HTTP3/Frame.hs +97/−84
- Network/HTTP3/Internal.hs +3/−3
- Network/HTTP3/Recv.hs +53/−54
- Network/HTTP3/Send.hs +47/−32
- Network/HTTP3/Server.hs +102/−87
- Network/HTTP3/Settings.hs +10/−8
- Network/HTTP3/Stream.hs +12/−9
- Network/QPACK.hs +118/−94
- Network/QPACK/Error.hs +20/−14
- Network/QPACK/HeaderBlock.hs +13/−12
- Network/QPACK/HeaderBlock/Decode.hs +65/−31
- Network/QPACK/HeaderBlock/Encode.hs +115/−86
- Network/QPACK/HeaderBlock/Prefix.hs +25/−21
- Network/QPACK/Instruction.hs +108/−86
- Network/QPACK/Internal.hs +9/−8
- Network/QPACK/Table.hs +33/−29
- Network/QPACK/Table/Dynamic.hs +49/−41
- Network/QPACK/Table/RevIndex.hs +62/−48
- Network/QPACK/Table/Static.hs +112/−108
- Network/QPACK/Token.hs +79/−4
- Network/QPACK/Types.hs +24/−10
- http3.cabal +3/−3
- test/HTTP3/Error.hs +1/−1
- test/HTTP3/ServerSpec.hs +9/−9
- util/ClientX.hs +31/−23
- util/Common.hs +19/−19
- util/ServerX.hs +9/−7
- util/client.hs +354/−269
- util/qif.hs +60/−48
- util/server.hs +83/−66
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for http3 +## 0.0.7++* Supporting http2 v5.0.+ ## 0.0.6 * Rescuing GHC 9.0 for testing.
Network/HQ/Client.hs view
@@ -3,38 +3,44 @@ {-# LANGUAGE RecordWildCards #-} -- | A client library for HTTP/0.9.- module Network.HQ.Client (- -- * Runner- run- -- * Runner arguments- , H3.ClientConfig(..)- , H3.Config(..)- , H3.allocSimpleConfig- , H3.freeSimpleConfig- , H3.Scheme- , H3.Authority- -- * HQ client- , H2.Client- -- * Request- , Request- -- * Creating request- , H2.requestNoBody- -- * Response- , Response- -- ** Accessing response- , H2.getResponseBodyChunk- ) where+ -- * Runner+ run, + -- * Runner arguments+ H3.ClientConfig (..),+ H3.Config (..),+ H3.allocSimpleConfig,+ H3.freeSimpleConfig,+ H3.Scheme,+ H3.Authority,++ -- * HQ client+ H2.Client,++ -- * Request+ Request,++ -- * Creating request+ H2.requestNoBody,++ -- * Response+ Response,++ -- ** Accessing response+ H2.getResponseBodyChunk,+) where+ import qualified Data.ByteString as BS import Data.IORef import Data.Maybe (fromJust) import Network.HPACK import qualified Network.HTTP2.Client as H2-import Network.HTTP2.Client.Internal (Request(..), Response(..))-import Network.HTTP2.Internal (InpObj(..))+import Network.HTTP2.Client.Internal (Request (..), Response (..), Aux (..))+import Network.HTTP2.Internal (InpObj (..)) import qualified Network.HTTP2.Internal as H2 import Network.QUIC (Connection)+import Network.QUIC.Internal (possibleMyStreams) import qualified Network.QUIC as QUIC import qualified UnliftIO.Exception as E @@ -43,7 +49,12 @@ -- | Running an HQ client. run :: Connection -> H3.ClientConfig -> H3.Config -> H2.Client a -> IO a-run conn _ _ client = client $ sendRequest conn+run conn _ _ client = client (sendRequest conn) aux+ where+ aux =+ Aux+ { auxPossibleClientStreams = possibleMyStreams conn+ } sendRequest :: Connection -> Request -> (Response -> IO a) -> IO a sendRequest conn (Request outobj) processResponse = E.bracket open close $ \strm -> do
Network/HQ/Server.hs view
@@ -2,42 +2,47 @@ {-# LANGUAGE RecordWildCards #-} -- | A server library for HTTP/0.9.- module Network.HQ.Server (- -- * Runner- run- -- * Runner arguments- , Config(..)- , allocSimpleConfig- , freeSimpleConfig- -- * HQ server- , Server- -- * Request- , Request- -- ** Accessing request- , H2.requestPath- -- * Response- , Response- -- ** Creating response- , H2.responseNoBody- , H2.responseFile- , H2.responseStreaming- , H2.responseBuilder- ) where+ -- * Runner+ run, + -- * Runner arguments+ Config (..),+ allocSimpleConfig,+ freeSimpleConfig,++ -- * HQ server+ Server,++ -- * Request+ Request,++ -- ** Accessing request+ H2.requestPath,++ -- * Response+ Response,++ -- ** Creating response+ H2.responseNoBody,+ H2.responseFile,+ H2.responseStreaming,+ H2.responseBuilder,+) where+ import Control.Concurrent+import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString as BS import Data.IORef import Foreign.ForeignPtr import Network.HPACK (HeaderTable, toHeaderTable)-import Network.HTTP2.Internal (InpObj(..))+import Network.HTTP2.Internal (InpObj (..)) import qualified Network.HTTP2.Internal as H2+import Network.HTTP2.Server (PushPromise, Server) import qualified Network.HTTP2.Server as H2-import Network.HTTP2.Server (Server, PushPromise)-import Network.HTTP2.Server.Internal (Request(..), Response(..), Aux(..))+import Network.HTTP2.Server.Internal (Aux (..), Request (..), Response (..)) import Network.QUIC (Connection, Stream) import qualified Network.QUIC as QUIC import Network.SockAddr (showSockAddrBS)@@ -56,11 +61,13 @@ peersa = QUIC.remoteSockAddr info forever $ do strm <- QUIC.acceptStream conn- forkFinally (processRequest conf mysa peersa server strm) (\_ -> QUIC.closeStream strm)+ forkFinally+ (processRequest conf mysa peersa server strm)+ (\_ -> QUIC.closeStream strm) processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO () processRequest conf mysa peersa server strm- | QUIC.isClientInitiatedBidirectional sid = do+ | QUIC.isClientInitiatedBidirectional sid = do th <- T.register (confTimeoutManager conf) (return ()) vt <- recvHeader strm mysa src <- newSource strm@@ -69,28 +76,29 @@ req = Request $ InpObj vt Nothing readB refH aux = Aux th mysa peersa server req aux $ sendResponse conf strm- | otherwise = return () -- fixme: should consume the data?+ | otherwise = return () -- fixme: should consume the data? where sid = QUIC.streamId strm recvHeader :: Stream -> SockAddr -> IO HeaderTable recvHeader strm myaddr = do- (method,path) <- recvRequestLine id+ (method, path) <- recvRequestLine id let auth = showSockAddrBS myaddr- vt = (":path",path)- : (":method", method)- : (":scheme", "https")- : (":authority", auth)- : []+ vt =+ (":path", path)+ : (":method", method)+ : (":scheme", "https")+ : (":authority", auth)+ : [] toHeaderTable vt where recvRequestLine builder = do bs <- QUIC.recvStream strm 1024- if bs == "" then do- return $ parseRequestLine $ BS.concat $ builder []- else- recvRequestLine (builder . (bs :))- parseRequestLine bs = (method,path)+ if bs == ""+ then do+ return $ parseRequestLine $ BS.concat $ builder []+ else recvRequestLine (builder . (bs :))+ parseRequestLine bs = (method, path) where method = "GET" path0 = BS.drop 4 bs@@ -103,10 +111,10 @@ (pread, sentinel') <- confPositionReadMaker conf path let timmgr = confTimeoutManager conf refresh <- case sentinel' of- H2.Closer closer -> do- th <- T.register timmgr closer- return $ T.tickle th- H2.Refresher refresher -> return refresher+ H2.Closer closer -> do+ th <- T.register timmgr closer+ return $ T.tickle th+ H2.Refresher refresher -> return refresher let next = H2.fillFileBodyGetNext pread fileoff bytecount refresh sendNext strm next H2.OutBodyBuilder builder -> do@@ -120,14 +128,14 @@ sendNext strm action = do fp <- BS.mallocByteString 2048 H2.Next len _reqflush mnext <- withForeignPtr fp $ \buf -> action buf 2048 65536 -- window size- if len == 0 then- return ()- else do- let bs = PS fp 0 len- QUIC.sendStream strm bs- case mnext of- Nothing -> return ()- Just next -> sendNext strm next+ if len == 0+ then return ()+ else do+ let bs = PS fp 0 len+ QUIC.sendStream strm bs+ case mnext of+ Nothing -> return ()+ Just next -> sendNext strm next sendStreaming :: Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO () sendStreaming strm strmbdy = do@@ -148,9 +156,9 @@ newByteStringAndSend strm action = do fp <- BS.mallocByteString 2048 (len, signal) <- withForeignPtr fp $ \buf -> action buf 2048- if len == 0 then- return signal- else do- let bs = PS fp 0 len- QUIC.sendStream strm bs- return signal+ if len == 0+ then return signal+ else do+ let bs = PS fp 0 len+ QUIC.sendStream strm bs+ return signal
Network/HTTP3/Client.hs view
@@ -3,65 +3,75 @@ {-# LANGUAGE RecordWildCards #-} -- | A client library for HTTP/3.- module Network.HTTP3.Client (- -- * Runner- run- -- * Runner arguments- , ClientConfig(..)- , Config(..)- , allocSimpleConfig- , freeSimpleConfig- , Hooks(..)- , defaultHooks- , Scheme- , Authority- -- * HTTP\/3 client- , Client- -- * Request- , Request- -- * Creating request- , H2.requestNoBody- , H2.requestFile- , H2.requestStreaming- , H2.requestBuilder- -- ** Trailers maker- , H2.TrailersMaker- , H2.NextTrailersMaker(..)- , H2.defaultTrailersMaker- , H2.setRequestTrailersMaker- -- * Response- , Response- -- ** Accessing response- , H2.responseStatus- , H2.responseHeaders- , H2.responseBodySize- , H2.getResponseBodyChunk- , H2.getResponseTrailers- -- * Types- , H2.Method- , H2.Path- , H2.FileSpec(..)- , H2.FileOffset- , H2.ByteCount- -- * RecvN- , H2.defaultReadN- -- * Position read for files- , H2.PositionReadMaker- , H2.PositionRead- , H2.Sentinel(..)- , H2.defaultPositionReadMaker- ) where+ -- * Runner+ run, + -- * Runner arguments+ ClientConfig (..),+ Config (..),+ allocSimpleConfig,+ freeSimpleConfig,+ Hooks (..),+ defaultHooks,+ Scheme,+ Authority,++ -- * HTTP\/3 client+ Client,++ -- * Request+ Request,++ -- * Creating request+ H2.requestNoBody,+ H2.requestFile,+ H2.requestStreaming,+ H2.requestBuilder,++ -- ** Trailers maker+ H2.TrailersMaker,+ H2.NextTrailersMaker (..),+ H2.defaultTrailersMaker,+ H2.setRequestTrailersMaker,++ -- * Response+ Response,++ -- ** Accessing response+ H2.responseStatus,+ H2.responseHeaders,+ H2.responseBodySize,+ H2.getResponseBodyChunk,+ H2.getResponseTrailers,++ -- * Types+ H2.Method,+ H2.Path,+ H2.FileSpec (..),+ H2.FileOffset,+ H2.ByteCount,++ -- * RecvN+ H2.defaultReadN,++ -- * Position read for files+ H2.PositionReadMaker,+ H2.PositionRead,+ H2.Sentinel (..),+ H2.defaultPositionReadMaker,+) where+ import Control.Concurrent import Data.IORef-import Network.HTTP2.Client (Scheme, Authority, Client)+import Network.HTTP2.Client (Authority, Client, Scheme) import qualified Network.HTTP2.Client as H2-import Network.HTTP2.Client.Internal (Request(..), Response(..))-import Network.HTTP2.Internal (InpObj(..))+import Network.HTTP2.Client.Internal (Aux (..), Request (..), Response (..))+import Network.HTTP2.Internal (InpObj (..)) import qualified Network.HTTP2.Internal as H2 import Network.QUIC (Connection) import qualified Network.QUIC as QUIC+import Network.QUIC.Internal (possibleMyStreams) import qualified UnliftIO.Exception as E import Network.HTTP3.Config@@ -74,10 +84,10 @@ -- | Configuration for HTTP\/3 or HQ client. For HQ, 'authority' is -- not used and an server's IP address is used in 'Request'.-data ClientConfig = ClientConfig {- scheme :: Scheme- , authority :: Authority- }+data ClientConfig = ClientConfig+ { scheme :: Scheme+ , authority :: Authority+ } -- | Running an HTTP\/3 client. run :: Connection -> ClientConfig -> Config -> H2.Client a -> IO a@@ -86,12 +96,16 @@ addThreadId ctx tid0 tid1 <- forkIO $ readerClient ctx addThreadId ctx tid1- client $ sendRequest ctx scheme authority+ client (sendRequest ctx scheme authority) aux where open = do ref <- newIORef IInit newContext conn conf (controlStream conn ref) close = clearContext+ aux =+ Aux+ { auxPossibleClientStreams = possibleMyStreams conn+ } readerClient :: Context -> IO () readerClient ctx = loop@@ -100,22 +114,24 @@ accept ctx >>= process loop process strm- | QUIC.isClientInitiatedUnidirectional sid = return () -- error- | QUIC.isClientInitiatedBidirectional sid = return ()- | QUIC.isServerInitiatedUnidirectional sid = do+ | QUIC.isClientInitiatedUnidirectional sid = return () -- error+ | QUIC.isClientInitiatedBidirectional sid = return ()+ | QUIC.isServerInitiatedUnidirectional sid = do tid <- forkIO $ unidirectional ctx strm addThreadId ctx tid- | otherwise = return () -- push?+ | otherwise = return () -- push? where sid = QUIC.streamId strm -sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a+sendRequest+ :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a sendRequest ctx scm auth (Request outobj) processResponse = do th <- registerThread ctx let hdr = H2.outObjHeaders outobj- hdr' = (":scheme", scm)- : (":authority", auth)- : hdr+ hdr' =+ (":scheme", scm)+ : (":authority", auth)+ : hdr E.bracket (newStream ctx) closeStream $ \strm -> do sendHeader ctx strm th hdr' tid <- forkIO $ do@@ -125,14 +141,14 @@ src <- newSource strm mvt <- recvHeader ctx src case mvt of- Nothing -> do- QUIC.resetStream strm H3MessageError- threadDelay 100000- -- just for type inference- E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""- Just vt -> do- refI <- newIORef IInit- refH <- newIORef Nothing- let readB = recvBody ctx src refI refH- rsp = Response $ InpObj vt Nothing readB refH- processResponse rsp+ Nothing -> do+ QUIC.resetStream strm H3MessageError+ threadDelay 100000+ -- just for type inference+ E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""+ Just vt -> do+ refI <- newIORef IInit+ refH <- newIORef Nothing+ let readB = recvBody ctx src refI refH+ rsp = Response $ InpObj vt Nothing readB refH+ processResponse rsp
Network/HTTP3/Config.hs view
@@ -6,30 +6,31 @@ import qualified System.TimeManager as T -- | Hooks mainly for error testing.-data Hooks = Hooks {- onControlFrameCreated :: [H3Frame] -> [H3Frame]- , onHeadersFrameCreated :: [H3Frame] -> [H3Frame]- , onControlStreamCreated :: Stream -> IO ()- , onEncoderStreamCreated :: Stream -> IO ()- , onDecoderStreamCreated :: Stream -> IO ()- }+data Hooks = Hooks+ { onControlFrameCreated :: [H3Frame] -> [H3Frame]+ , onHeadersFrameCreated :: [H3Frame] -> [H3Frame]+ , onControlStreamCreated :: Stream -> IO ()+ , onEncoderStreamCreated :: Stream -> IO ()+ , onDecoderStreamCreated :: Stream -> IO ()+ } -- | Default hooks. defaultHooks :: Hooks-defaultHooks = Hooks {- onControlFrameCreated = id- , onHeadersFrameCreated = id- , onControlStreamCreated = \_ -> return ()- , onEncoderStreamCreated = \_ -> return ()- , onDecoderStreamCreated = \_ -> return ()- }+defaultHooks =+ Hooks+ { onControlFrameCreated = id+ , onHeadersFrameCreated = id+ , onControlStreamCreated = \_ -> return ()+ , onEncoderStreamCreated = \_ -> return ()+ , onDecoderStreamCreated = \_ -> return ()+ } -- | Configuration for HTTP\/3 or HQ.-data Config = Config {- confHooks :: Hooks- , confPositionReadMaker :: PositionReadMaker- , confTimeoutManager :: T.Manager- }+data Config = Config+ { confHooks :: Hooks+ , confPositionReadMaker :: PositionReadMaker+ , confTimeoutManager :: T.Manager+ } -- | Allocating a simple configuration with a handle-based position -- reader and a locally allocated timeout manager.
Network/HTTP3/Context.hs view
@@ -2,34 +2,34 @@ {-# LANGUAGE RecordWildCards #-} module Network.HTTP3.Context (- Context- , newContext- , clearContext- , unidirectional- , isH3Server- , isH3Client- , accept- , qpackEncode- , qpackDecode- , registerThread- , timeoutClose- , newStream- , closeStream- , pReadMaker- , addThreadId- , abort- , getHooks- , Hooks(..) -- re-export- , getMySockAddr- , getPeerSockAddr- ) where+ Context,+ newContext,+ clearContext,+ unidirectional,+ isH3Server,+ isH3Client,+ accept,+ qpackEncode,+ qpackDecode,+ registerThread,+ timeoutClose,+ newStream,+ closeStream,+ pReadMaker,+ addThreadId,+ abort,+ getHooks,+ Hooks (..), -- re-export+ getMySockAddr,+ getPeerSockAddr,+) where import Control.Concurrent import qualified Data.ByteString as BS import Data.IORef import Network.HTTP2.Internal (PositionReadMaker) import Network.QUIC-import Network.QUIC.Internal (isServer, isClient, connDebugLog)+import Network.QUIC.Internal (connDebugLog, isClient, isServer) import Network.Socket (SockAddr) import System.Mem.Weak import qualified System.TimeManager as T@@ -40,18 +40,18 @@ import Network.QPACK import Network.QPACK.Internal -data Context = Context {- ctxConnection :: Connection- , ctxQEncoder :: QEncoder- , ctxQDecoder :: QDecoder- , ctxUniSwitch :: H3StreamType -> InstructionHandler- , ctxPReadMaker :: PositionReadMaker- , ctxManager :: T.Manager- , ctxHooks :: Hooks- , ctxMySockAddr :: SockAddr- , ctxPeerSockAddr :: SockAddr- , ctxThreads :: IORef [Weak ThreadId]- }+data Context = Context+ { ctxConnection :: Connection+ , ctxQEncoder :: QEncoder+ , ctxQDecoder :: QDecoder+ , ctxUniSwitch :: H3StreamType -> InstructionHandler+ , ctxPReadMaker :: PositionReadMaker+ , ctxManager :: T.Manager+ , ctxHooks :: Hooks+ , ctxMySockAddr :: SockAddr+ , ctxPeerSockAddr :: SockAddr+ , ctxThreads :: IORef [Weak ThreadId]+ } newContext :: Connection -> Config -> InstructionHandler -> IO Context newContext conn conf ctl = do@@ -63,7 +63,7 @@ sw = switch conn ctl handleEI' handleDI' preadM = confPositionReadMaker conf timmgr = confTimeoutManager conf- hooks = confHooks conf+ hooks = confHooks conf mysa = localSockAddr info peersa = remoteSockAddr info Context conn enc dec sw preadM timmgr hooks mysa peersa <$> newIORef []@@ -73,12 +73,18 @@ clearContext :: Context -> IO () clearContext ctx = clearThreads ctx -switch :: Connection -> InstructionHandler -> InstructionHandler -> InstructionHandler -> H3StreamType -> InstructionHandler+switch+ :: Connection+ -> InstructionHandler+ -> InstructionHandler+ -> InstructionHandler+ -> H3StreamType+ -> InstructionHandler switch conn ctl handleEI handleDI styp- | styp == H3ControlStreams = ctl- | styp == QPACKEncoderStream = handleEI- | styp == QPACKDecoderStream = handleDI- | otherwise = \_ -> connDebugLog conn "switch unknown stream type"+ | styp == H3ControlStreams = ctl+ | styp == QPACKEncoderStream = handleEI+ | styp == QPACKDecoderStream = handleDI+ | otherwise = \_ -> connDebugLog conn "switch unknown stream type" isH3Server :: Context -> Bool isH3Server Context{..} = isServer ctxConnection@@ -97,7 +103,7 @@ unidirectional :: Context -> Stream -> IO () unidirectional Context{..} strm = do- w8:_ <- BS.unpack <$> recvStream strm 1 -- fixme: variable length+ w8 : _ <- BS.unpack <$> recvStream strm 1 -- fixme: variable length let typ = toH3StreamType $ fromIntegral w8 ctxUniSwitch typ (recvStream strm) @@ -118,7 +124,7 @@ addThreadId :: Context -> ThreadId -> IO () addThreadId Context{..} tid = do wtid <- mkWeakThreadId tid- atomicModifyIORef' ctxThreads $ \ts -> (wtid:ts, ())+ atomicModifyIORef' ctxThreads $ \ts -> (wtid : ts, ()) clearThreads :: Context -> IO () clearThreads Context{..} = do@@ -129,8 +135,8 @@ kill wtid = do mtid <- deRefWeak wtid case mtid of- Nothing -> return ()- Just tid -> killThread tid+ Nothing -> return ()+ Just tid -> killThread tid abort :: Context -> ApplicationProtocolError -> IO () abort ctx aerr = abortConnection (ctxConnection ctx) aerr ""
Network/HTTP3/Control.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP3.Control (- setupUnidirectional- , controlStream- ) where+ setupUnidirectional,+ controlStream,+) where import qualified Data.ByteString as BS import Data.IORef@@ -11,10 +11,10 @@ import Imports import qualified Network.HTTP3.Config as H3+import Network.HTTP3.Error import Network.HTTP3.Frame import Network.HTTP3.Settings import Network.HTTP3.Stream-import Network.HTTP3.Error import Network.QPACK mkType :: H3StreamType -> ByteString@@ -22,10 +22,12 @@ setupUnidirectional :: Connection -> H3.Config -> IO () setupUnidirectional conn conf = do- settings <- encodeH3Settings [(SettingsQpackBlockedStreams,100)- ,(SettingsQpackMaxTableCapacity,4096)- ,(SettingsMaxFieldSectionSize,32768)- ] -- fixme+ settings <-+ encodeH3Settings+ [ (SettingsQpackBlockedStreams, 100)+ , (SettingsQpackMaxTableCapacity, 4096)+ , (SettingsMaxFieldSectionSize, 32768)+ ] -- fixme let framesC = H3.onControlFrameCreated hooks [H3Frame H3FrameSettings settings] let bssC = encodeH3Frames framesC sC <- unidirectionalStream conn@@ -49,41 +51,42 @@ where loop0 = do bs <- recv 1024- if bs == "" then- abortConnection conn H3ClosedCriticalStream ""- else do- (done, st1) <- readIORef ref >>= parse0 bs- writeIORef ref st1- if done then loop else loop0+ if bs == ""+ then abortConnection conn H3ClosedCriticalStream ""+ else do+ (done, st1) <- readIORef ref >>= parse0 bs+ writeIORef ref st1+ if done then loop else loop0 loop = do bs <- recv 1024- if bs == "" then- abortConnection conn H3ClosedCriticalStream ""- else do- readIORef ref >>= parse bs >>= writeIORef ref- loop+ if bs == ""+ then abortConnection conn H3ClosedCriticalStream ""+ else do+ readIORef ref >>= parse bs >>= writeIORef ref+ loop parse0 bs st0 = do case parseH3Frame st0 bs of- IDone typ payload leftover -> do- case typ of- H3FrameSettings -> checkSettings conn payload- _ -> abortConnection conn H3MissingSettings ""- st1 <- parse leftover IInit- return (True, st1)- st1 -> return (False, st1)+ IDone typ payload leftover -> do+ case typ of+ H3FrameSettings -> checkSettings conn payload+ _ -> abortConnection conn H3MissingSettings ""+ st1 <- parse leftover IInit+ return (True, st1)+ st1 -> return (False, st1) parse bs st0 = do case parseH3Frame st0 bs of- IDone typ _payload leftover -> do- case typ of- H3FrameCancelPush -> return ()- H3FrameSettings -> abortConnection conn H3FrameUnexpected ""- H3FrameGoaway -> return ()- H3FrameMaxPushId -> return ()- _ | permittedInControlStream typ -> return ()- | otherwise -> abortConnection conn H3FrameUnexpected ""- parse leftover IInit- st1 -> return st1+ IDone typ _payload leftover -> do+ case typ of+ H3FrameCancelPush -> return ()+ H3FrameSettings -> abortConnection conn H3FrameUnexpected ""+ H3FrameGoaway -> return ()+ H3FrameMaxPushId -> return ()+ _+ | permittedInControlStream typ -> return ()+ | otherwise -> abortConnection conn H3FrameUnexpected ""+ parse leftover IInit+ st1 -> return st1 checkSettings :: Connection -> ByteString -> IO () checkSettings conn payload = do@@ -91,15 +94,15 @@ loop (0 :: Int) h3settings where loop _ [] = return ()- loop flags ((k@(H3SettingsKey i),_v):ss)- | flags `testBit` i = abortConnection conn H3SettingsError ""- | otherwise = do+ loop flags ((k@(H3SettingsKey i), _v) : ss)+ | flags `testBit` i = abortConnection conn H3SettingsError ""+ | otherwise = do let flags' = flags `setBit` i case k of- SettingsQpackMaxTableCapacity -> loop flags' ss- SettingsMaxFieldSectionSize -> loop flags' ss- SettingsQpackBlockedStreams -> loop flags' ss- _- -- HTTP/2 settings- | i <= 0x6 -> abortConnection conn H3SettingsError ""- | otherwise -> return ()+ SettingsQpackMaxTableCapacity -> loop flags' ss+ SettingsMaxFieldSectionSize -> loop flags' ss+ SettingsQpackBlockedStreams -> loop flags' ss+ _+ -- HTTP/2 settings+ | i <= 0x6 -> abortConnection conn H3SettingsError ""+ | otherwise -> return ()
Network/HTTP3/Error.hs view
@@ -1,28 +1,30 @@ {-# LANGUAGE PatternSynonyms #-} module Network.HTTP3.Error (- ApplicationProtocolError(H3NoError- ,H3GeneralProtocolError- ,H3InternalError- ,H3StreamCreationError- ,H3ClosedCriticalStream- ,H3FrameUnexpected- ,H3FrameError- ,H3ExcessiveLoad- ,H3IdError- ,H3SettingsError- ,H3MissingSettings- ,H3RequestRejected- ,H3RequestCancelled- ,H3RequestIncomplete- ,H3MessageError- ,H3ConnectError- ,H3VersionFallback- )- ) where+ ApplicationProtocolError (+ H3NoError,+ H3GeneralProtocolError,+ H3InternalError,+ H3StreamCreationError,+ H3ClosedCriticalStream,+ H3FrameUnexpected,+ H3FrameError,+ H3ExcessiveLoad,+ H3IdError,+ H3SettingsError,+ H3MissingSettings,+ H3RequestRejected,+ H3RequestCancelled,+ H3RequestIncomplete,+ H3MessageError,+ H3ConnectError,+ H3VersionFallback+ ),+) where import Network.QUIC +{- FOURMOLU_DISABLE -} pattern H3NoError :: ApplicationProtocolError pattern H3NoError = ApplicationProtocolError 0x100 @@ -73,3 +75,4 @@ pattern H3VersionFallback :: ApplicationProtocolError pattern H3VersionFallback = ApplicationProtocolError 0x110+{- FOURMOLU_ENABLE -}
Network/HTTP3/Frame.hs view
@@ -1,22 +1,22 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HTTP3.Frame (- H3Frame(..)- , H3FrameType(..)- , fromH3FrameType- , toH3FrameType- , encodeH3Frame- , encodeH3Frames- , decodeH3Frame- , IFrame(..)- , parseH3Frame- , QInt(..)- , parseQInt- , permittedInControlStream- , permittedInRequestStream- , permittedInPushStream- ) where+ H3Frame (..),+ H3FrameType (..),+ fromH3FrameType,+ toH3FrameType,+ encodeH3Frame,+ encodeH3Frames,+ decodeH3Frame,+ IFrame (..),+ parseH3Frame,+ QInt (..),+ parseQInt,+ permittedInControlStream,+ permittedInRequestStream,+ permittedInPushStream,+) where import qualified Data.ByteString as BS import Network.ByteOrder@@ -26,16 +26,18 @@ data H3Frame = H3Frame H3FrameType ByteString -data H3FrameType = H3FrameData- | H3FrameHeaders- | H3FrameCancelPush- | H3FrameSettings- | H3FramePushPromise- | H3FrameGoaway- | H3FrameMaxPushId- | H3FrameUnknown Int64- deriving (Eq, Show)+data H3FrameType+ = H3FrameData+ | H3FrameHeaders+ | H3FrameCancelPush+ | H3FrameSettings+ | H3FramePushPromise+ | H3FrameGoaway+ | H3FrameMaxPushId+ | H3FrameUnknown Int64+ deriving (Eq, Show) +{- FOURMOLU_DISABLE -} fromH3FrameType :: H3FrameType -> Int64 fromH3FrameType H3FrameData = 0x0 fromH3FrameType H3FrameHeaders = 0x1@@ -44,7 +46,7 @@ fromH3FrameType H3FramePushPromise = 0x5 fromH3FrameType H3FrameGoaway = 0x7 fromH3FrameType H3FrameMaxPushId = 0xD-fromH3FrameType (H3FrameUnknown i) = i+fromH3FrameType (H3FrameUnknown i) = i toH3FrameType :: Int64 -> H3FrameType toH3FrameType 0x0 = H3FrameData@@ -54,7 +56,7 @@ toH3FrameType 0x5 = H3FramePushPromise toH3FrameType 0x7 = H3FrameGoaway toH3FrameType 0xD = H3FrameMaxPushId-toH3FrameType i = H3FrameUnknown i+toH3FrameType i = H3FrameUnknown i permittedInControlStream :: H3FrameType -> Bool permittedInControlStream H3FrameData = False@@ -65,8 +67,8 @@ permittedInControlStream H3FrameGoaway = True permittedInControlStream H3FrameMaxPushId = True permittedInControlStream (H3FrameUnknown i)- | i <= 0x9 = False- | otherwise = True+ | i <= 0x9 = False+ | otherwise = True permittedInRequestStream :: H3FrameType -> Bool permittedInRequestStream H3FrameData = True@@ -77,8 +79,8 @@ permittedInRequestStream H3FrameGoaway = False permittedInRequestStream H3FrameMaxPushId = False permittedInRequestStream (H3FrameUnknown i)- | i <= 0x9 = False- | otherwise = True+ | i <= 0x9 = False+ | otherwise = True permittedInPushStream :: H3FrameType -> Bool permittedInPushStream H3FrameData = True@@ -89,8 +91,9 @@ permittedInPushStream H3FrameGoaway = False permittedInPushStream H3FrameMaxPushId = False permittedInPushStream (H3FrameUnknown i)- | i <= 0x9 = False- | otherwise = True+ | i <= 0x9 = False+ | otherwise = True+{- FOURMOLU_ENABLE -} encodeH3Frame :: H3Frame -> IO ByteString encodeH3Frame (H3Frame typ bs) = do@@ -102,8 +105,8 @@ encodeH3Frames :: [H3Frame] -> [ByteString] encodeH3Frames fs0 = loop fs0 id where- loop [] build = build []- loop (H3Frame ty val:fs) build = loop fs (build . (typ :) . (len :) . (val :))+ loop [] build = build []+ loop (H3Frame ty val : fs) build = loop fs (build . (typ :) . (len :) . (val :)) where typ = encodeInt $ fromIntegral $ fromH3FrameType ty len = encodeInt $ fromIntegral $ BS.length val@@ -115,31 +118,36 @@ bs <- extractByteString rbuf len return $ H3Frame typ bs -data QInt = QInit- | QMore Word8 -- Masked first byte- Int -- Bytes required- Int -- Bytes received so far. (sum . map length)- [ByteString] -- Reverse order- | QDone Int64 -- Result- ByteString -- leftover- deriving (Eq,Show)+data QInt+ = QInit+ | QMore+ Word8 -- Masked first byte+ Int -- Bytes required+ Int -- Bytes received so far. (sum . map length)+ [ByteString] -- Reverse order+ | QDone+ Int64 -- Result+ ByteString -- leftover+ deriving (Eq, Show) parseQInt :: QInt -> ByteString -> QInt parseQInt st "" = st parseQInt QInit bs0- | len1 < reqLen = QMore ft reqLen len1 [bs1]- | otherwise = let (bs2,bs3) = BS.splitAt reqLen bs1- in QDone (toLen ft bs2) bs3+ | len1 < reqLen = QMore ft reqLen len1 [bs1]+ | otherwise =+ let (bs2, bs3) = BS.splitAt reqLen bs1+ in QDone (toLen ft bs2) bs3 where hd = BS.head bs0 reqLen = requiredLen (hd .&. 0b11000000) ft = hd .&. 0b00111111- bs1 = BS.tail bs0+ bs1 = BS.tail bs0 len1 = BS.length bs1 parseQInt (QMore ft reqLen len0 bss0) bs0- | len1 < reqLen = QMore ft reqLen len1 (bs0:bss0)- | otherwise = let (bs2,bs3) = BS.splitAt reqLen $ compose bs0 bss0- in QDone (toLen ft bs2) bs3+ | len1 < reqLen = QMore ft reqLen len1 (bs0 : bss0)+ | otherwise =+ let (bs2, bs3) = BS.splitAt reqLen $ compose bs0 bss0+ in QDone (toLen ft bs2) bs3 where len1 = len0 + BS.length bs0 parseQInt (QDone _ _) _ = error "parseQInt"@@ -148,57 +156,62 @@ requiredLen 0b00000000 = 0 requiredLen 0b01000000 = 1 requiredLen 0b10000000 = 3-requiredLen _ = 7+requiredLen _ = 7 toLen :: Word8 -> ByteString -> Int64 toLen w0 bs = BS.foldl (\n w -> n * 256 + fromIntegral w) (fromIntegral w0) bs -data IFrame =- -- | Parsing is about to start- IInit- -- | Parsing type- | IType QInt- -- | Parsing length- | ILen H3FrameType QInt- -- | Parsing payload- | IPay H3FrameType- Int -- Bytes required- Int -- Bytes received so far. (sum . map length)- [ByteString] -- Reverse order- -- | Parsing done- | IDone H3FrameType- ByteString -- Payload (entire or sentinel)- ByteString -- Leftover- deriving (Eq, Show)+data IFrame+ = -- | Parsing is about to start+ IInit+ | -- | Parsing type+ IType QInt+ | -- | Parsing length+ ILen H3FrameType QInt+ | -- | Parsing payload+ IPay+ H3FrameType+ Int -- Bytes required+ Int -- Bytes received so far. (sum . map length)+ [ByteString] -- Reverse order+ | -- | Parsing done+ IDone+ H3FrameType+ ByteString -- Payload (entire or sentinel)+ ByteString -- Leftover+ deriving (Eq, Show) parseH3Frame :: IFrame -> ByteString -> IFrame parseH3Frame st "" = st parseH3Frame IInit bs = case parseQInt QInit bs of- QDone i bs' -> let typ = toH3FrameType i- in parseH3Frame (ILen typ QInit) bs'- ist -> IType ist+ QDone i bs' ->+ let typ = toH3FrameType i+ in parseH3Frame (ILen typ QInit) bs'+ ist -> IType ist parseH3Frame (IType ist) bs = case parseQInt ist bs of- QDone i bs' -> let typ = toH3FrameType i- in parseH3Frame (ILen typ QInit) bs'- ist' -> IType ist'+ QDone i bs' ->+ let typ = toH3FrameType i+ in parseH3Frame (ILen typ QInit) bs'+ ist' -> IType ist' parseH3Frame (ILen typ ist) bs = case parseQInt ist bs of- QDone i bs' -> let reqLen = fromIntegral i- in if reqLen == 0 then- IDone typ "" bs'- else- parseH3Frame (IPay typ reqLen 0 []) bs'- ist' -> ILen typ ist'+ QDone i bs' ->+ let reqLen = fromIntegral i+ in if reqLen == 0+ then IDone typ "" bs'+ else parseH3Frame (IPay typ reqLen 0 []) bs'+ ist' -> ILen typ ist' parseH3Frame (IPay typ reqLen len0 bss0) bs0 = case len1 `compare` reqLen of- LT -> IPay typ reqLen len1 (bs0:bss0)+ LT -> IPay typ reqLen len1 (bs0 : bss0) EQ -> IDone typ (compose bs0 bss0) ""- GT -> let (bs2,leftover) = BS.splitAt (reqLen - len0) bs0- in IDone typ (compose bs2 bss0) leftover+ GT ->+ let (bs2, leftover) = BS.splitAt (reqLen - len0) bs0+ in IDone typ (compose bs2 bss0) leftover where len1 = len0 + BS.length bs0 parseH3Frame st _ = st compose :: ByteString -> [ByteString] -> ByteString-compose bs bss = BS.concat $ reverse (bs:bss)+compose bs bss = BS.concat $ reverse (bs : bss) {- test :: Int64 -> QInt
Network/HTTP3/Internal.hs view
@@ -1,7 +1,7 @@ module Network.HTTP3.Internal (- module Network.HTTP3.Error- , module Network.HTTP3.Frame- ) where+ module Network.HTTP3.Error,+ module Network.HTTP3.Frame,+) where import Network.HTTP3.Error import Network.HTTP3.Frame
Network/HTTP3/Recv.hs view
@@ -2,12 +2,12 @@ {-# LANGUAGE RecordWildCards #-} module Network.HTTP3.Recv (- Source- , newSource- , readSource- , recvHeader- , recvBody- ) where+ Source,+ newSource,+ readSource,+ recvHeader,+ recvBody,+) where import qualified Data.ByteString as BS import Data.IORef@@ -19,10 +19,10 @@ import Network.HTTP3.Error import Network.HTTP3.Frame -data Source = Source {- sourceRead :: IO ByteString- , sourcePending :: IORef (Maybe ByteString)- }+data Source = Source+ { sourceRead :: IO ByteString+ , sourcePending :: IORef (Maybe ByteString)+ } newSource :: Stream -> IO Source newSource strm = Source (recvStream strm 1024) <$> newIORef Nothing@@ -31,10 +31,10 @@ readSource Source{..} = do mx <- readIORef sourcePending case mx of- Nothing -> sourceRead- Just x -> do- writeIORef sourcePending Nothing- return x+ Nothing -> sourceRead+ Just x -> do+ writeIORef sourcePending Nothing+ return x pushbackSource :: Source -> ByteString -> IO () pushbackSource _ "" = return ()@@ -45,58 +45,57 @@ where loop st = do bs <- readSource src- if bs == "" then- return Nothing- else- case parseH3Frame st bs of- IDone typ payload leftover- | typ == H3FrameHeaders -> do+ if bs == ""+ then return Nothing+ else case parseH3Frame st bs of+ IDone typ payload leftover+ | typ == H3FrameHeaders -> do pushbackSource src leftover Just <$> qpackDecode ctx payload- | typ == H3FrameData -> do+ | typ == H3FrameData -> do abort ctx H3FrameUnexpected loop IInit -- dummy- | permittedInRequestStream typ -> do+ | permittedInRequestStream typ -> do pushbackSource src leftover loop IInit- | otherwise -> do+ | otherwise -> do abort ctx H3FrameUnexpected loop IInit -- dummy- st' -> loop st'+ st' -> loop st' -recvBody :: Context -> Source -> IORef IFrame -> IORef (Maybe HeaderTable) -> IO ByteString+recvBody+ :: Context -> Source -> IORef IFrame -> IORef (Maybe HeaderTable) -> IO ByteString recvBody ctx src refI refH = do st <- readIORef refI loop st where loop st = do bs <- readSource src- if bs == "" then- return ""- else- case parseH3Frame st bs of- IPay H3FrameData siz received bss -> do- let st' = IPay H3FrameData siz received []- if null bss then- loop st'- else do- writeIORef refI st'- return $ BS.concat $ reverse bss- IDone typ payload leftover- | typ == H3FrameHeaders -> do- writeIORef refI IInit- -- pushbackSource src leftover -- fixme- hdr <- qpackDecode ctx payload- writeIORef refH $ Just hdr- return ""- | typ == H3FrameData -> do- writeIORef refI IInit- pushbackSource src leftover- return payload- | permittedInRequestStream typ -> do- pushbackSource src leftover- loop IInit- | otherwise -> do- abort ctx H3FrameUnexpected- return payload -- dummy- st' -> loop st'+ if bs == ""+ then return ""+ else case parseH3Frame st bs of+ IPay H3FrameData siz received bss -> do+ let st' = IPay H3FrameData siz received []+ if null bss+ then loop st'+ else do+ writeIORef refI st'+ return $ BS.concat $ reverse bss+ IDone typ payload leftover+ | typ == H3FrameHeaders -> do+ writeIORef refI IInit+ -- pushbackSource src leftover -- fixme+ hdr <- qpackDecode ctx payload+ writeIORef refH $ Just hdr+ return ""+ | typ == H3FrameData -> do+ writeIORef refI IInit+ pushbackSource src leftover+ return payload+ | permittedInRequestStream typ -> do+ pushbackSource src leftover+ loop IInit+ | otherwise -> do+ abort ctx H3FrameUnexpected+ return payload -- dummy+ st' -> loop st'
Network/HTTP3/Send.hs view
@@ -2,9 +2,9 @@ {-# LANGUAGE RankNTypes #-} module Network.HTTP3.Send (- sendHeader- , sendBody- ) where+ sendHeader,+ sendBody,+) where import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B@@ -39,14 +39,20 @@ OutBodyFile (FileSpec path fileoff bytecount) -> do (pread, sentinel') <- pReadMaker ctx path refresh <- case sentinel' of- Closer closer -> timeoutClose ctx closer- Refresher refresher -> return refresher+ Closer closer -> timeoutClose ctx closer+ Refresher refresher -> return refresher let next = fillFileBodyGetNext pread fileoff bytecount refresh sendNext ctx strm th next tlrmkr OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder sendNext ctx strm th next tlrmkr- OutBodyStreaming strmbdy -> sendStreaming ctx strm th tlrmkr (\unmask push flush -> unmask $ strmbdy push flush)+ OutBodyStreaming strmbdy ->+ sendStreaming+ ctx+ strm+ th+ tlrmkr+ (\unmask push flush -> unmask $ strmbdy push flush) OutBodyStreamingUnmask strmbdy -> sendStreaming ctx strm th tlrmkr strmbdy where tlrmkr = outObjTrailers outobj@@ -57,39 +63,48 @@ when (bs /= "") $ encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm T.tickle th case mnext of- Nothing -> do- Trailers trailers <- tlrmkr Nothing- unless (null trailers) $ sendHeader ctx strm th trailers- Just next -> sendNext ctx strm th next tlrmkr+ Nothing -> do+ Trailers trailers <- tlrmkr Nothing+ unless (null trailers) $ sendHeader ctx strm th trailers+ Just next -> sendNext ctx strm th next tlrmkr -newByteStringWith :: TrailersMaker -> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker)+newByteStringWith+ :: TrailersMaker -> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker) newByteStringWith tlrmkr0 action = do fp <- BS.mallocByteString 2048 Next len _reqflush mnext1 <- withForeignPtr fp $ \buf -> action buf 2048 65536 -- window size- if len == 0 then- return ("", Nothing, tlrmkr0)- else do- let bs = PS fp 0 len- NextTrailersMaker tlrmkr1 <- tlrmkr0 $ Just bs- return (bs, mnext1, tlrmkr1)+ if len == 0+ then return ("", Nothing, tlrmkr0)+ else do+ let bs = PS fp 0 len+ NextTrailersMaker tlrmkr1 <- tlrmkr0 $ Just bs+ return (bs, mnext1, tlrmkr1) -newByteStringAndSend :: Stream -> T.Handle -> TrailersMaker -> B.BufferWriter- -> IO (B.Next, TrailersMaker)+newByteStringAndSend+ :: Stream+ -> T.Handle+ -> TrailersMaker+ -> B.BufferWriter+ -> IO (B.Next, TrailersMaker) newByteStringAndSend strm th tlrmkr0 action = do fp <- BS.mallocByteString 2048 (len, signal) <- withForeignPtr fp $ \buf -> action buf 2048- if len == 0 then- return (signal, tlrmkr0)- else do- let bs = PS fp 0 len- NextTrailersMaker tlrmkr1 <- tlrmkr0 $ Just bs- encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm- T.tickle th- return (signal, tlrmkr1)+ if len == 0+ then return (signal, tlrmkr0)+ else do+ let bs = PS fp 0 len+ NextTrailersMaker tlrmkr1 <- tlrmkr0 $ Just bs+ encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm+ T.tickle th+ return (signal, tlrmkr1) -sendStreaming :: Context -> Stream -> T.Handle -> TrailersMaker- -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())- -> IO ()+sendStreaming+ :: Context+ -> Stream+ -> T.Handle+ -> TrailersMaker+ -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())+ -> IO () sendStreaming ctx strm th tlrmkr0 strmbdy = do ref <- newIORef tlrmkr0 E.mask $ \unmask -> strmbdy unmask (write ref) flush@@ -103,8 +118,8 @@ tlrmkr2 <- newByteStringAndSend strm th tlrmkr1 (B.runBuilder builder) >>= loop writeIORef ref tlrmkr2 where- loop (B.Done, tlrmkr1) = return tlrmkr1- loop (B.More _ writer, tlrmkr1) =+ loop (B.Done, tlrmkr1) = return tlrmkr1+ loop (B.More _ writer, tlrmkr1) = newByteStringAndSend strm th tlrmkr1 writer >>= loop loop (B.Chunk bs writer, tlrmkr1) = do encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm
Network/HTTP3/Server.hs view
@@ -2,75 +2,87 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | A server library for HTTP/3.- module Network.HTTP3.Server (- -- * Runner- run- -- * Runner arguments- , Config(..)- , allocSimpleConfig- , freeSimpleConfig- , Hooks(..)- , defaultHooks- -- * HTTP\/3 server- , Server- -- * Request- , Request- -- ** Accessing request- , H2.requestMethod- , H2.requestPath- , H2.requestAuthority- , H2.requestScheme- , H2.requestHeaders- , H2.requestBodySize- , H2.getRequestBodyChunk- , H2.getRequestTrailers- -- * Aux- , Aux- , auxTimeHandle- -- * Response- , Response- -- ** Creating response- , H2.responseNoBody- , H2.responseFile- , H2.responseStreaming- , H2.responseBuilder- -- ** Accessing response- , H2.responseBodySize- -- ** Trailers maker- , H2.TrailersMaker- , H2.NextTrailersMaker(..)- , H2.defaultTrailersMaker- , H2.setResponseTrailersMaker- -- * Push promise- , PushPromise- , H2.pushPromise- , H2.promiseRequestPath- , H2.promiseResponse- -- * Types- , H2.Path- , H2.Authority- , H2.Scheme- , H2.FileSpec(..)- , H2.FileOffset- , H2.ByteCount- -- * RecvN- , H2.defaultReadN- -- * Position read for files- , H2.PositionReadMaker- , H2.PositionRead- , H2.Sentinel(..)- , H2.defaultPositionReadMaker- ) where+ -- * Runner+ run, + -- * Runner arguments+ Config (..),+ allocSimpleConfig,+ freeSimpleConfig,+ Hooks (..),+ defaultHooks,++ -- * HTTP\/3 server+ Server,++ -- * Request+ Request,++ -- ** Accessing request+ H2.requestMethod,+ H2.requestPath,+ H2.requestAuthority,+ H2.requestScheme,+ H2.requestHeaders,+ H2.requestBodySize,+ H2.getRequestBodyChunk,+ H2.getRequestTrailers,++ -- * Aux+ Aux,+ auxTimeHandle,++ -- * Response+ Response,++ -- ** Creating response+ H2.responseNoBody,+ H2.responseFile,+ H2.responseStreaming,+ H2.responseBuilder,++ -- ** Accessing response+ H2.responseBodySize,++ -- ** Trailers maker+ H2.TrailersMaker,+ H2.NextTrailersMaker (..),+ H2.defaultTrailersMaker,+ H2.setResponseTrailersMaker,++ -- * Push promise+ PushPromise,+ H2.pushPromise,+ H2.promiseRequestPath,+ H2.promiseResponse,++ -- * Types+ H2.Path,+ H2.Authority,+ H2.Scheme,+ H2.FileSpec (..),+ H2.FileOffset,+ H2.ByteCount,++ -- * RecvN+ H2.defaultReadN,++ -- * Position read for files+ H2.PositionReadMaker,+ H2.PositionRead,+ H2.Sentinel (..),+ H2.defaultPositionReadMaker,+) where+ import Control.Concurrent import Data.IORef import Network.HPACK.Token-import Network.HTTP2.Internal (InpObj(..))+import Network.HTTP2.Internal (InpObj (..)) import qualified Network.HTTP2.Internal as H2-import Network.HTTP2.Server (Server, PushPromise)+import Network.HTTP2.Server (PushPromise, Server) import qualified Network.HTTP2.Server as H2-import Network.HTTP2.Server.Internal (Request(..), Response(..), Aux(..))+import Network.HTTP2.Server.Internal (Aux (..), Request (..), Response (..)) import Network.QUIC (Connection, Stream) import qualified Network.QUIC as QUIC import qualified System.TimeManager as T@@ -106,12 +118,13 @@ accept ctx >>= process loop process strm- | QUIC.isClientInitiatedUnidirectional sid = do+ | QUIC.isClientInitiatedUnidirectional sid = do tid <- forkIO $ unidirectional ctx strm addThreadId ctx tid- | QUIC.isClientInitiatedBidirectional sid = void $ forkFinally (processRequest ctx server strm) (\_ -> closeStream strm)- | QUIC.isServerInitiatedUnidirectional sid = return () -- error- | otherwise = return ()+ | QUIC.isClientInitiatedBidirectional sid =+ void $ forkFinally (processRequest ctx server strm) (\_ -> closeStream strm)+ | QUIC.isServerInitiatedUnidirectional sid = return () -- error+ | otherwise = return () where sid = QUIC.streamId strm @@ -121,30 +134,32 @@ src <- newSource strm mvt <- recvHeader ctx src case mvt of- Nothing -> QUIC.resetStream strm H3MessageError- Just ht@(_,vt) -> do- let mMethod = getHeaderValue tokenMethod vt- mScheme = getHeaderValue tokenScheme vt- mAuthority = getHeaderValue tokenAuthority vt- mPath = getHeaderValue tokenPath vt- case (mMethod, mScheme, mAuthority, mPath) of- (Just "CONNECT", _, Just _, _) -> return ()- (Just _, Just _, Just _, Just _) -> return ()- _ -> QUIC.resetStream strm H3MessageError- -- fixme: Content-Length- refI <- newIORef IInit- refH <- newIORef Nothing- let readB = recvBody ctx src refI refH- req = Request $ InpObj ht Nothing readB refH- let aux = Aux th (getMySockAddr ctx) (getPeerSockAddr ctx)- server req aux $ sendResponse ctx strm th+ Nothing -> QUIC.resetStream strm H3MessageError+ Just ht@(_, vt) -> do+ let mMethod = getHeaderValue tokenMethod vt+ mScheme = getHeaderValue tokenScheme vt+ mAuthority = getHeaderValue tokenAuthority vt+ mPath = getHeaderValue tokenPath vt+ case (mMethod, mScheme, mAuthority, mPath) of+ (Just "CONNECT", _, Just _, _) -> return ()+ (Just _, Just _, Just _, Just _) -> return ()+ _ -> QUIC.resetStream strm H3MessageError+ -- fixme: Content-Length+ refI <- newIORef IInit+ refH <- newIORef Nothing+ let readB = recvBody ctx src refI refH+ req = Request $ InpObj ht Nothing readB refH+ let aux = Aux th (getMySockAddr ctx) (getPeerSockAddr ctx)+ server req aux $ sendResponse ctx strm th where reset se- | Just (_ :: DecodeError) <- E.fromException se = abort ctx QpackDecompressionFailed- | otherwise = QUIC.resetStream strm H3MessageError+ | Just (_ :: DecodeError) <- E.fromException se =+ abort ctx QpackDecompressionFailed+ | otherwise = QUIC.resetStream strm H3MessageError -sendResponse :: Context -> Stream -> T.Handle -> Response -> [PushPromise] -> IO ()+sendResponse+ :: Context -> Stream -> T.Handle -> Response -> [PushPromise] -> IO () sendResponse ctx strm th (Response outobj) _pp = do sendHeader ctx strm th $ H2.outObjHeaders outobj- sendBody ctx strm th outobj+ sendBody ctx strm th outobj QUIC.shutdownStream strm
Network/HTTP3/Settings.hs view
@@ -5,10 +5,11 @@ import Network.ByteOrder import Network.QUIC.Internal -type H3Settings = [(H3SettingsKey,Int)]+type H3Settings = [(H3SettingsKey, Int)] newtype H3SettingsKey = H3SettingsKey Int deriving (Eq, Show) +{- FOURMOLU_DISABLE -} pattern SettingsQpackMaxTableCapacity :: H3SettingsKey pattern SettingsQpackMaxTableCapacity = H3SettingsKey 0x1 @@ -17,12 +18,13 @@ pattern SettingsQpackBlockedStreams :: H3SettingsKey pattern SettingsQpackBlockedStreams = H3SettingsKey 0x7+{- FOURMOLU_ENABLE -} encodeH3Settings :: H3Settings -> IO ByteString encodeH3Settings kvs = withWriteBuffer 128 $ \wbuf -> do mapM_ (enc wbuf) kvs where- enc wbuf (H3SettingsKey k,v) = do+ enc wbuf (H3SettingsKey k, v) = do encodeInt' wbuf $ fromIntegral k encodeInt' wbuf $ fromIntegral v @@ -32,11 +34,11 @@ dec rbuf = do k <- H3SettingsKey . fromIntegral <$> decodeInt' rbuf v <- fromIntegral <$> decodeInt' rbuf- return (k,v)+ return (k, v) loop rbuf build = do r <- remainingSize rbuf- if r <= 0 then- return $ build []- else do- kv <- dec rbuf- loop rbuf (build . (kv :))+ if r <= 0+ then return $ build []+ else do+ kv <- dec rbuf+ loop rbuf (build . (kv :))
Network/HTTP3/Stream.hs view
@@ -4,13 +4,15 @@ import Imports -data H3StreamType = H3ControlStreams- | H3PushStreams- | QPACKEncoderStream- | QPACKDecoderStream- | H3StreamTypeUnknown Int64- deriving (Eq, Show)+data H3StreamType+ = H3ControlStreams+ | H3PushStreams+ | QPACKEncoderStream+ | QPACKDecoderStream+ | H3StreamTypeUnknown Int64+ deriving (Eq, Show) +{- FOURMOLU_DISABLE -} fromH3StreamType :: H3StreamType -> Int64 fromH3StreamType H3ControlStreams = 0x00 fromH3StreamType H3PushStreams = 0x01@@ -23,14 +25,15 @@ toH3StreamType 0x01 = H3PushStreams toH3StreamType 0x02 = QPACKEncoderStream toH3StreamType 0x03 = QPACKDecoderStream-toH3StreamType i = H3StreamTypeUnknown i+toH3StreamType i = H3StreamTypeUnknown i+{- FOURMOLU_ENABLE -} -clientControlStream,clientEncoderStream,clientDecoderStream :: StreamId+clientControlStream, clientEncoderStream, clientDecoderStream :: StreamId clientControlStream = 2 clientEncoderStream = 6 clientDecoderStream = 10 -serverControlStream,serverEncoderStream,serverDecoderStream :: StreamId+serverControlStream, serverEncoderStream, serverDecoderStream :: StreamId serverControlStream = 3 serverEncoderStream = 7 serverDecoderStream = 11
Network/QPACK.hs view
@@ -3,48 +3,60 @@ -- | Thread-safe QPACK encoder/decoder. module Network.QPACK (- -- * Encoder- QEncoderConfig(..)- , defaultQEncoderConfig- , QEncoder- , newQEncoder- -- * Decoder- , QDecoderConfig(..)- , defaultQDecoderConfig- , QDecoder- , newQDecoder- -- ** Decoder for debugging- , QDecoderS- , newQDecoderS- -- * Types- , EncodedEncoderInstruction- , EncoderInstructionHandler- , EncoderInstructionHandlerS- , EncodedDecoderInstruction- , DecoderInstructionHandler- , InstructionHandler- , Size- -- * Strategy- , EncodeStrategy(..)- , CompressionAlgo(..)- -- * Re-exports- , HeaderTable- , TokenHeaderList- , ValueTable- , Header- , HeaderList- , getHeaderValue- , toHeaderTable- , original- , foldedCase- , mk- ) where+ -- * Encoder+ QEncoderConfig (..),+ defaultQEncoderConfig,+ QEncoder,+ newQEncoder, + -- * Decoder+ QDecoderConfig (..),+ defaultQDecoderConfig,+ QDecoder,+ newQDecoder,++ -- ** Decoder for debugging+ QDecoderS,+ newQDecoderS,++ -- * Types+ EncodedEncoderInstruction,+ EncoderInstructionHandler,+ EncoderInstructionHandlerS,+ EncodedDecoderInstruction,+ DecoderInstructionHandler,+ InstructionHandler,+ Size,++ -- * Strategy+ EncodeStrategy (..),+ CompressionAlgo (..),++ -- * Re-exports+ HeaderTable,+ TokenHeaderList,+ ValueTable,+ Header,+ HeaderList,+ getHeaderValue,+ toHeaderTable,+ original,+ foldedCase,+ mk,+) where+ import Control.Concurrent.STM import qualified Data.ByteString as B import Data.CaseInsensitive import Network.ByteOrder-import Network.HPACK (HeaderTable, TokenHeaderList, HeaderList, ValueTable, getHeaderValue, toHeaderTable)+import Network.HPACK (+ HeaderList,+ HeaderTable,+ TokenHeaderList,+ ValueTable,+ getHeaderValue,+ toHeaderTable,+ ) import Network.HPACK.Internal import Network.QUIC.Internal (stdoutLogger) import qualified UnliftIO.Exception as E@@ -59,13 +71,14 @@ ---------------------------------------------------------------- -- | QPACK encoder.-type QEncoder = TokenHeaderList -> IO (EncodedFieldSection, EncodedEncoderInstruction)+type QEncoder =+ TokenHeaderList -> IO (EncodedFieldSection, EncodedEncoderInstruction) -- | QPACK decoder. type QDecoder = EncodedFieldSection -> IO HeaderTable -- | QPACK simple decoder.-type QDecoderS =EncodedFieldSection -> IO HeaderList+type QDecoderS = EncodedFieldSection -> IO HeaderList -- | Encoder instruction handler. type EncoderInstructionHandler = (Int -> IO EncodedEncoderInstruction) -> IO ()@@ -85,26 +98,28 @@ ---------------------------------------------------------------- -- | Configuration for QPACK encoder.-data QEncoderConfig = QEncoderConfig {- ecDynamicTableSize :: Size- , ecHeaderBlockBufferSize :: Size- , ecPrefixBufferSize :: Size- , ecInstructionBufferSize :: Size- , encStrategy :: EncodeStrategy- } deriving Show+data QEncoderConfig = QEncoderConfig+ { ecDynamicTableSize :: Size+ , ecHeaderBlockBufferSize :: Size+ , ecPrefixBufferSize :: Size+ , ecInstructionBufferSize :: Size+ , encStrategy :: EncodeStrategy+ }+ deriving (Show) -- | Default configuration for QPACK encoder. -- -- >>> defaultQEncoderConfig -- QEncoderConfig {ecDynamicTableSize = 4096, ecHeaderBlockBufferSize = 4096, ecPrefixBufferSize = 128, ecInstructionBufferSize = 4096, encStrategy = EncodeStrategy {compressionAlgo = Static, useHuffman = True}} defaultQEncoderConfig :: QEncoderConfig-defaultQEncoderConfig = QEncoderConfig {- ecDynamicTableSize = 4096- , ecHeaderBlockBufferSize = 4096- , ecPrefixBufferSize = 128- , ecInstructionBufferSize = 4096- , encStrategy = EncodeStrategy Static True- }+defaultQEncoderConfig =+ QEncoderConfig+ { ecDynamicTableSize = 4096+ , ecHeaderBlockBufferSize = 4096+ , ecPrefixBufferSize = 128+ , ecInstructionBufferSize = 4096+ , encStrategy = EncodeStrategy Static True+ } -- | Creating a new QPACK encoder. newQEncoder :: QEncoderConfig -> IO (QEncoder, DecoderInstructionHandler)@@ -120,37 +135,42 @@ handler = decoderInstructionHandler dyntbl return (enc, handler) -qpackEncoder :: EncodeStrategy- -> GCBuffer -> Int- -> GCBuffer -> Int- -> GCBuffer -> Int- -> DynamicTable- -> TokenHeaderList- -> IO (EncodedFieldSection,EncodedEncoderInstruction)+qpackEncoder+ :: EncodeStrategy+ -> GCBuffer+ -> Int+ -> GCBuffer+ -> Int+ -> GCBuffer+ -> Int+ -> DynamicTable+ -> TokenHeaderList+ -> IO (EncodedFieldSection, EncodedEncoderInstruction) qpackEncoder stgy gcbuf1 bufsiz1 gcbuf2 bufsiz2 gcbuf3 bufsiz3 dyntbl ts = withForeignPtr gcbuf1 $ \buf1 ->- withForeignPtr gcbuf2 $ \buf2 ->- withForeignPtr gcbuf3 $ \buf3 -> do- wbuf1 <- newWriteBuffer buf1 bufsiz1- wbuf2 <- newWriteBuffer buf2 bufsiz2- wbuf3 <- newWriteBuffer buf3 bufsiz3- thl <- encodeTokenHeader wbuf1 wbuf3 stgy dyntbl ts -- fixme: leftover- when (thl /= []) $ stdoutLogger "qpackEncoder: leftover"- hb0 <- toByteString wbuf1- ins <- toByteString wbuf3- encodePrefix wbuf2 dyntbl- prefix <- toByteString wbuf2- let hb = prefix `B.append` hb0- return (hb, ins)+ withForeignPtr gcbuf2 $ \buf2 ->+ withForeignPtr gcbuf3 $ \buf3 -> do+ wbuf1 <- newWriteBuffer buf1 bufsiz1+ wbuf2 <- newWriteBuffer buf2 bufsiz2+ wbuf3 <- newWriteBuffer buf3 bufsiz3+ thl <- encodeTokenHeader wbuf1 wbuf3 stgy dyntbl ts -- fixme: leftover+ when (thl /= []) $ stdoutLogger "qpackEncoder: leftover"+ hb0 <- toByteString wbuf1+ ins <- toByteString wbuf3+ encodePrefix wbuf2 dyntbl+ prefix <- toByteString wbuf2+ let hb = prefix `B.append` hb0+ return (hb, ins) -decoderInstructionHandler :: DynamicTable -> (Int -> IO EncodedDecoderInstruction) -> IO ()+decoderInstructionHandler+ :: DynamicTable -> (Int -> IO EncodedDecoderInstruction) -> IO () decoderInstructionHandler dyntbl recv = loop where loop = do _ <- getInsertionPoint dyntbl -- fixme bs <- recv 1024 when (bs /= "") $ do- (ins,leftover) <- decodeDecoderInstructions bs -- fixme: saving leftover+ (ins, leftover) <- decodeDecoderInstructions bs -- fixme: saving leftover when (leftover /= "") $ stdoutLogger "decoderInstructionHandler: leftover" qpackDebug dyntbl $ mapM_ print ins mapM_ handle ins@@ -158,26 +178,28 @@ handle (SectionAcknowledgement _n) = return () handle (StreamCancellation _n) = return () handle (InsertCountIncrement n)- | n == 0 = E.throwIO DecoderInstructionError- | otherwise = return ()+ | n == 0 = E.throwIO DecoderInstructionError+ | otherwise = return () ---------------------------------------------------------------- -- | Configuration for QPACK decoder.-data QDecoderConfig = QDecoderConfig {- dcDynamicTableSize :: Size- , dcHuffmanBufferSize :: Size- } deriving Show+data QDecoderConfig = QDecoderConfig+ { dcDynamicTableSize :: Size+ , dcHuffmanBufferSize :: Size+ }+ deriving (Show) -- | Default configuration for QPACK decoder. -- -- >>> defaultQDecoderConfig -- QDecoderConfig {dcDynamicTableSize = 4096, dcHuffmanBufferSize = 4096} defaultQDecoderConfig :: QDecoderConfig-defaultQDecoderConfig = QDecoderConfig {- dcDynamicTableSize = 4096- , dcHuffmanBufferSize = 4096- }+defaultQDecoderConfig =+ QDecoderConfig+ { dcDynamicTableSize = 4096+ , dcHuffmanBufferSize = 4096+ } -- | Creating a new QPACK decoder. newQDecoder :: QDecoderConfig -> IO (QDecoder, EncoderInstructionHandler)@@ -188,7 +210,8 @@ return (dec, handler) -- | Creating a new simple QPACK decoder.-newQDecoderS :: QDecoderConfig -> Bool -> IO (QDecoderS, EncoderInstructionHandlerS)+newQDecoderS+ :: QDecoderConfig -> Bool -> IO (QDecoderS, EncoderInstructionHandlerS) newQDecoderS QDecoderConfig{..} debug = do dyntbl <- newDynamicTableForDecoding dcDynamicTableSize dcHuffmanBufferSize when debug $ setDebugQPACK dyntbl@@ -202,7 +225,8 @@ qpackDecoderS :: DynamicTable -> EncodedFieldSection -> IO HeaderList qpackDecoderS dyntbl bs = withReadBuffer bs $ \rbuf -> decodeTokenHeaderS dyntbl rbuf -encoderInstructionHandler :: DynamicTable -> (Int -> IO EncodedEncoderInstruction) -> IO ()+encoderInstructionHandler+ :: DynamicTable -> (Int -> IO EncodedEncoderInstruction) -> IO () encoderInstructionHandler dyntbl recv = loop where loop = do@@ -213,7 +237,7 @@ encoderInstructionHandlerS :: DynamicTable -> EncodedEncoderInstruction -> IO () encoderInstructionHandlerS dyntbl bs = when (bs /= "") $ do- (ins,leftover) <- decodeEncoderInstructions hufdec bs -- fixme: saving leftover+ (ins, leftover) <- decodeEncoderInstructions hufdec bs -- fixme: saving leftover when (leftover /= "") $ stdoutLogger "encoderInstructionHandler: leftover" qpackDebug dyntbl $ mapM_ print ins@@ -221,14 +245,14 @@ where hufdec = getHuffmanDecoder dyntbl handle (SetDynamicTableCapacity n)- | n > 4096 = E.throwIO EncoderInstructionError- | otherwise = return ()+ | n > 4096 = E.throwIO EncoderInstructionError+ | otherwise = return () handle (InsertWithNameReference ii val) = atomically $ do idx <- case ii of- Left ai -> return $ SIndex ai- Right ri -> do- ip <- getInsertionPointSTM dyntbl- return $ DIndex $ fromInsRelativeIndex ri ip+ Left ai -> return $ SIndex ai+ Right ri -> do+ ip <- getInsertionPointSTM dyntbl+ return $ DIndex $ fromInsRelativeIndex ri ip ent0 <- toIndexedEntry dyntbl idx let ent = toEntryToken (entryToken ent0) val insertEntryToDecoder ent dyntbl
Network/QPACK/Error.hs view
@@ -1,21 +1,23 @@ {-# LANGUAGE PatternSynonyms #-} module Network.QPACK.Error (- -- * Errors- ApplicationProtocolError(QpackDecompressionFailed- ,QpackEncoderStreamError- ,QpackDecoderStreamError- )- , DecodeError(..)- , EncoderInstructionError(..)- , DecoderInstructionError(..)- ) where+ -- * Errors+ ApplicationProtocolError (+ QpackDecompressionFailed,+ QpackEncoderStreamError,+ QpackDecoderStreamError+ ),+ DecodeError (..),+ EncoderInstructionError (..),+ DecoderInstructionError (..),+) where import Data.Typeable import UnliftIO.Exception import Network.QUIC +{- FOURMOLU_DISABLE -} pattern QpackDecompressionFailed :: ApplicationProtocolError pattern QpackDecompressionFailed = ApplicationProtocolError 0x200 @@ -24,13 +26,17 @@ pattern QpackDecoderStreamError :: ApplicationProtocolError pattern QpackDecoderStreamError = ApplicationProtocolError 0x202+{- FOURMOLU_ENABLE -} -data DecodeError = IllegalStaticIndex- | IllegalInsertCount- deriving (Eq,Show,Typeable)+data DecodeError+ = IllegalStaticIndex+ | IllegalInsertCount+ deriving (Eq, Show, Typeable) -data EncoderInstructionError = EncoderInstructionError deriving (Eq,Show,Typeable)-data DecoderInstructionError = DecoderInstructionError deriving (Eq,Show,Typeable)+data EncoderInstructionError = EncoderInstructionError+ deriving (Eq, Show, Typeable)+data DecoderInstructionError = DecoderInstructionError+ deriving (Eq, Show, Typeable) instance Exception DecodeError instance Exception EncoderInstructionError
Network/QPACK/HeaderBlock.hs view
@@ -1,16 +1,17 @@ module Network.QPACK.HeaderBlock (- -- * Encoder- encodeHeader- , encodeTokenHeader- , EncodedFieldSection- , EncodedEncoderInstruction- , EncodeStrategy(..)- , CompressionAlgo(..)- , encodePrefix- -- * Decoder- , decodeTokenHeader- , decodeTokenHeaderS- ) where+ -- * Encoder+ encodeHeader,+ encodeTokenHeader,+ EncodedFieldSection,+ EncodedEncoderInstruction,+ EncodeStrategy (..),+ CompressionAlgo (..),+ encodePrefix,++ -- * Decoder+ decodeTokenHeader,+ decodeTokenHeaderS,+) where import Network.QPACK.HeaderBlock.Decode import Network.QPACK.HeaderBlock.Encode
Network/QPACK/HeaderBlock/Decode.hs view
@@ -6,7 +6,7 @@ import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive import Network.ByteOrder-import Network.HPACK (TokenHeader, HeaderTable, HeaderList)+import Network.HPACK (HeaderList, HeaderTable, TokenHeader) import Network.HPACK.Internal import Network.HPACK.Token (toToken, tokenKey) @@ -15,89 +15,123 @@ import Network.QPACK.Table import Network.QPACK.Types -decodeTokenHeader :: DynamicTable- -> ReadBuffer- -> IO HeaderTable+decodeTokenHeader+ :: DynamicTable+ -> ReadBuffer+ -> IO HeaderTable decodeTokenHeader dyntbl rbuf = do (reqip, bp) <- decodePrefix rbuf dyntbl checkInsertionPoint dyntbl reqip decodeSophisticated (toTokenHeader dyntbl bp) rbuf -decodeTokenHeaderS :: DynamicTable- -> ReadBuffer- -> IO HeaderList+decodeTokenHeaderS+ :: DynamicTable+ -> ReadBuffer+ -> IO HeaderList decodeTokenHeaderS dyntbl rbuf = do (reqip, bp) <- decodePrefix rbuf dyntbl debug <- getDebugQPACK dyntbl unless debug $ checkInsertionPoint dyntbl reqip decodeSimple (toTokenHeader dyntbl bp) rbuf -toTokenHeader :: DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader+toTokenHeader+ :: DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader toTokenHeader dyntbl bp w8 rbuf- | w8 `testBit` 7 = decodeIndexedFieldLine rbuf dyntbl bp w8- | w8 `testBit` 6 = decodeLiteralFieldLineWithNameReference rbuf dyntbl bp w8- | w8 `testBit` 5 = decodeLiteralFieldLineWithoutNameReference rbuf dyntbl bp w8- | w8 `testBit` 4 = decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8- | otherwise = decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl bp w8+ | w8 `testBit` 7 = decodeIndexedFieldLine rbuf dyntbl bp w8+ | w8 `testBit` 6 = decodeLiteralFieldLineWithNameReference rbuf dyntbl bp w8+ | w8 `testBit` 5 = decodeLiteralFieldLineWithoutNameReference rbuf dyntbl bp w8+ | w8 `testBit` 4 = decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8+ | otherwise =+ decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl bp w8 -- 4.5.2. Indexed Field Line-decodeIndexedFieldLine :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader+decodeIndexedFieldLine+ :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader decodeIndexedFieldLine rbuf dyntbl bp w8 = do i <- decodeI 6 (w8 .&. 0b00111111) rbuf let static = w8 `testBit` 6- hidx | static = SIndex $ AbsoluteIndex i- | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp+ hidx+ | static = SIndex $ AbsoluteIndex i+ | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)- qpackDebug dyntbl $ putStrLn $ "IndexedFieldLine (" ++ show hidx ++ ") " ++ showTokenHeader ret+ qpackDebug dyntbl $+ putStrLn $+ "IndexedFieldLine (" ++ show hidx ++ ") " ++ showTokenHeader ret return ret -- 4.5.4. Literal Field Line With Name Reference-decodeLiteralFieldLineWithNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader+decodeLiteralFieldLineWithNameReference+ :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader decodeLiteralFieldLineWithNameReference rbuf dyntbl bp w8 = do i <- decodeI 4 (w8 .&. 0b00001111) rbuf let static = w8 `testBit` 4- hidx | static = SIndex $ AbsoluteIndex i- | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp+ hidx+ | static = SIndex $ AbsoluteIndex i+ | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx) let hufdec = getHuffmanDecoder dyntbl val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf- let ret = (key,val)- qpackDebug dyntbl $ putStrLn $ "LiteralFieldLineWithNameReference (" ++ show hidx ++ ") " ++ showTokenHeader ret+ let ret = (key, val)+ qpackDebug dyntbl $+ putStrLn $+ "LiteralFieldLineWithNameReference ("+ ++ show hidx+ ++ ") "+ ++ showTokenHeader ret return ret -- 4.5.6. Literal Field Line Without Name Reference-decodeLiteralFieldLineWithoutNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader+decodeLiteralFieldLineWithoutNameReference+ :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader decodeLiteralFieldLineWithoutNameReference rbuf dyntbl _bp _w8 = do ff rbuf (-1) let hufdec = getHuffmanDecoder dyntbl key <- toToken <$> decodeS (.&. 0b00000111) (`testBit` 3) 3 hufdec rbuf val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf- let ret = (key,val)- qpackDebug dyntbl $ putStrLn $ "LiteralFieldLineWithoutNameReference " ++ showTokenHeader ret+ let ret = (key, val)+ qpackDebug dyntbl $+ putStrLn $+ "LiteralFieldLineWithoutNameReference " ++ showTokenHeader ret return ret -- 4.5.3. Indexed Field Line With Post-Base Index-decodeIndexedFieldLineWithPostBaseIndex :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader+decodeIndexedFieldLineWithPostBaseIndex+ :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8 = do i <- decodeI 4 (w8 .&. 0b00001111) rbuf let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)- qpackDebug dyntbl $ putStrLn $ "IndexedFieldLineWithPostBaseIndex (" ++ show hidx ++ " " ++ show i ++ "/" ++ show bp ++ ") " ++ showTokenHeader ret+ qpackDebug dyntbl $+ putStrLn $+ "IndexedFieldLineWithPostBaseIndex ("+ ++ show hidx+ ++ " "+ ++ show i+ ++ "/"+ ++ show bp+ ++ ") "+ ++ showTokenHeader ret return ret -- 4.5.5. Literal Field Line With Post-Base Name Reference-decodeLiteralFieldLineWithPostBaseNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader+decodeLiteralFieldLineWithPostBaseNameReference+ :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl bp w8 = do i <- decodeI 3 (w8 .&. 0b00000111) rbuf let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx) let hufdec = getHuffmanDecoder dyntbl val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf- let ret = (key,val)- qpackDebug dyntbl $ putStrLn $ "LiteralFieldLineWithPostBaseNameReference (" ++ show hidx ++ ") " ++ showTokenHeader ret+ let ret = (key, val)+ qpackDebug dyntbl $+ putStrLn $+ "LiteralFieldLineWithPostBaseNameReference ("+ ++ show hidx+ ++ ") "+ ++ showTokenHeader ret return ret showTokenHeader :: TokenHeader -> String-showTokenHeader (t,val) = "\"" ++ key ++ "\" \"" ++ BS8.unpack val ++ "\""+showTokenHeader (t, val) = "\"" ++ key ++ "\" \"" ++ BS8.unpack val ++ "\"" where key = BS8.unpack $ foldedCase $ tokenKey t
Network/QPACK/HeaderBlock/Encode.hs view
@@ -2,18 +2,23 @@ {-# LANGUAGE RecordWildCards #-} module Network.QPACK.HeaderBlock.Encode (- encodeHeader- , encodeTokenHeader- , EncodedFieldSection- , EncodedEncoderInstruction- , EncodeStrategy(..)- , CompressionAlgo(..)- ) where+ encodeHeader,+ encodeTokenHeader,+ EncodedFieldSection,+ EncodedEncoderInstruction,+ EncodeStrategy (..),+ CompressionAlgo (..),+) where import qualified Data.ByteString as B import Data.IORef import Network.ByteOrder-import Network.HPACK (HeaderList, EncodeStrategy(..), TokenHeaderList, CompressionAlgo(..))+import Network.HPACK (+ CompressionAlgo (..),+ EncodeStrategy (..),+ HeaderList,+ TokenHeaderList,+ ) import Network.HPACK.Internal import Network.HPACK.Token import qualified UnliftIO.Exception as E@@ -26,6 +31,7 @@ -- | Encoded field section including prefix. type EncodedFieldSection = B.ByteString+ -- | Encoded encoder instruction. type EncodedEncoderInstruction = B.ByteString @@ -33,25 +39,33 @@ -- Header block with prefix and instructions are returned. -- 2048, 32, and 2048 bytes-buffers are -- temporally allocated for header block, prefix and encoder instructions.-encodeHeader :: EncodeStrategy -> DynamicTable -> HeaderList -> IO (EncodedFieldSection,EncodedEncoderInstruction)+encodeHeader+ :: EncodeStrategy+ -> DynamicTable+ -> HeaderList+ -> IO (EncodedFieldSection, EncodedEncoderInstruction) encodeHeader stgy dyntbl hs = do (hb0, insb) <- withWriteBuffer' 2048 $ \wbuf1 ->- withWriteBuffer 2048 $ \wbuf2 -> do- hs1 <- encodeTokenHeader wbuf1 wbuf2 stgy dyntbl ts- unless (null hs1) $ E.throwIO BufferOverrun+ withWriteBuffer 2048 $ \wbuf2 -> do+ hs1 <- encodeTokenHeader wbuf1 wbuf2 stgy dyntbl ts+ unless (null hs1) $ E.throwIO BufferOverrun prefix <- withWriteBuffer 32 $ \wbuf -> encodePrefix wbuf dyntbl let hb = prefix `B.append` hb0- return (hb,insb)+ return (hb, insb) where- ts = map (\(k,v) -> let t = toToken k in (t,v)) hs+ ts = map (\(k, v) -> let t = toToken k in (t, v)) hs -- | Converting 'TokenHeaderList' to the QPACK format.-encodeTokenHeader :: WriteBuffer -- ^ Workspace for the body of header block- -> WriteBuffer -- ^ Workspace for encoder instructions- -> EncodeStrategy- -> DynamicTable- -> TokenHeaderList- -> IO TokenHeaderList -- ^ Leftover+encodeTokenHeader+ :: WriteBuffer+ -- ^ Workspace for the body of header block+ -> WriteBuffer+ -- ^ Workspace for encoder instructions+ -> EncodeStrategy+ -> DynamicTable+ -> TokenHeaderList+ -> IO TokenHeaderList+ -- ^ Leftover encodeTokenHeader wbuf1 wbuf2 EncodeStrategy{..} dyntbl ts0 = do clearWriteBuffer wbuf1 clearWriteBuffer wbuf2@@ -59,74 +73,86 @@ let revidx = getRevIndex dyntbl ref <- newIORef ts0 case compressionAlgo of- Static -> encodeStatic wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return ()- _ -> encodeLinear wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return ()+ Static ->+ encodeStatic wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return ()+ _ ->+ encodeLinear wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return () ts <- readIORef ref unless (null ts) $ do goBack wbuf1 goBack wbuf2 return ts -encodeStatic :: WriteBuffer -> WriteBuffer- -> DynamicTable -> RevIndex -> Bool- -> IORef TokenHeaderList- -> TokenHeaderList -> IO ()+encodeStatic+ :: WriteBuffer+ -> WriteBuffer+ -> DynamicTable+ -> RevIndex+ -> Bool+ -> IORef TokenHeaderList+ -> TokenHeaderList+ -> IO () encodeStatic wbuf1 _wbuf2 dyntbl revidx huff ref ts0 = loop ts0 where loop [] = return ()- loop ((t,val):ts) = do+ loop ((t, val) : ts) = do rr <- lookupRevIndex t val revidx case rr of- KV hi -> do- -- 4.5.2. Indexed Field Line- encodeIndexedFieldLine wbuf1 dyntbl hi- K hi -> do- -- 4.5.4. Literal Field Line With Name Reference- encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff- N -> do- -- 4.5.6. Literal Field Line Without Name Reference- encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff+ KV hi -> do+ -- 4.5.2. Indexed Field Line+ encodeIndexedFieldLine wbuf1 dyntbl hi+ K hi -> do+ -- 4.5.4. Literal Field Line With Name Reference+ encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff+ N -> do+ -- 4.5.6. Literal Field Line Without Name Reference+ encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff save wbuf1 writeIORef ref ts loop ts -encodeLinear :: WriteBuffer -> WriteBuffer- -> DynamicTable -> RevIndex -> Bool- -> IORef TokenHeaderList- -> TokenHeaderList -> IO ()+encodeLinear+ :: WriteBuffer+ -> WriteBuffer+ -> DynamicTable+ -> RevIndex+ -> Bool+ -> IORef TokenHeaderList+ -> TokenHeaderList+ -> IO () encodeLinear wbuf1 wbuf2 dyntbl revidx huff ref ts0 = loop ts0 where loop [] = return ()- loop ((t,val):ts) = do+ loop ((t, val) : ts) = do rr <- lookupRevIndex t val revidx case rr of- KV hi -> do- -- 4.5.2. Indexed Field Line- encodeIndexedFieldLine wbuf1 dyntbl hi- K hi- | shouldBeIndexed t -> do- insidx <- case hi of- SIndex i -> return $ Left i- DIndex i -> do- ip <- getInsertionPoint dyntbl- return $ Right $ toInsRelativeIndex i ip- let ins = InsertWithNameReference insidx val- encodeEI wbuf2 True ins- dai <- insertEntryToEncoder (toEntryToken t val) dyntbl- -- 4.5.3. Indexed Field Line With Post-Base Index- encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai- | otherwise -> do- -- 4.5.4. Literal Field Line With Name Reference- encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff- N- | shouldBeIndexed t -> do- let ins = InsertWithoutNameReference t val- encodeEI wbuf2 True ins- dai <- insertEntryToEncoder (toEntryToken t val) dyntbl- encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai- | otherwise -> do- -- 4.5.6. Literal Field Line Without Name Reference- encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff+ KV hi -> do+ -- 4.5.2. Indexed Field Line+ encodeIndexedFieldLine wbuf1 dyntbl hi+ K hi+ | shouldBeIndexed t -> do+ insidx <- case hi of+ SIndex i -> return $ Left i+ DIndex i -> do+ ip <- getInsertionPoint dyntbl+ return $ Right $ toInsRelativeIndex i ip+ let ins = InsertWithNameReference insidx val+ encodeEI wbuf2 True ins+ dai <- insertEntryToEncoder (toEntryToken t val) dyntbl+ -- 4.5.3. Indexed Field Line With Post-Base Index+ encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai+ | otherwise -> do+ -- 4.5.4. Literal Field Line With Name Reference+ encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff+ N+ | shouldBeIndexed t -> do+ let ins = InsertWithoutNameReference t val+ encodeEI wbuf2 True ins+ dai <- insertEntryToEncoder (toEntryToken t val) dyntbl+ encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai+ | otherwise -> do+ -- 4.5.6. Literal Field Line Without Name Reference+ encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff save wbuf1 save wbuf2 writeIORef ref ts@@ -136,34 +162,36 @@ encodeIndexedFieldLine :: WriteBuffer -> DynamicTable -> HIndex -> IO () encodeIndexedFieldLine wbuf dyntbl hi = do (idx, set) <- case hi of- SIndex (AbsoluteIndex i) -> return (i, set11)- DIndex ai-> do- updateLargestReference dyntbl ai- bp <- getBasePoint dyntbl- let HBRelativeIndex i = toHBRelativeIndex ai bp- return (i, set10)+ SIndex (AbsoluteIndex i) -> return (i, set11)+ DIndex ai -> do+ updateLargestReference dyntbl ai+ bp <- getBasePoint dyntbl+ let HBRelativeIndex i = toHBRelativeIndex ai bp+ return (i, set10) encodeI wbuf set 6 idx -- 4.5.3. Indexed Field Line With Post-Base Index-encodeIndexedFieldLineWithPostBaseIndex :: WriteBuffer- -> DynamicTable- -> AbsoluteIndex -- in Dynamic table- -> IO ()+encodeIndexedFieldLineWithPostBaseIndex+ :: WriteBuffer+ -> DynamicTable+ -> AbsoluteIndex -- in Dynamic table+ -> IO () encodeIndexedFieldLineWithPostBaseIndex wbuf dyntbl ai = do bp <- getBasePoint dyntbl let HBRelativeIndex idx = toHBRelativeIndex ai bp encodeI wbuf set0001 4 idx -- 4.5.4. Literal Field Line With Name Reference-encodeLiteralFieldLineWithNameReference :: WriteBuffer -> DynamicTable -> HIndex -> ByteString -> Bool -> IO ()+encodeLiteralFieldLineWithNameReference+ :: WriteBuffer -> DynamicTable -> HIndex -> ByteString -> Bool -> IO () encodeLiteralFieldLineWithNameReference wbuf dyntbl hi val huff = do (idx, set) <- case hi of- SIndex (AbsoluteIndex i) -> return (i, set0101)- DIndex ai-> do- updateLargestReference dyntbl ai- bp <- getBasePoint dyntbl- let HBRelativeIndex i = toHBRelativeIndex ai bp- return (i, set0100)+ SIndex (AbsoluteIndex i) -> return (i, set0101)+ DIndex ai -> do+ updateLargestReference dyntbl ai+ bp <- getBasePoint dyntbl+ let HBRelativeIndex i = toHBRelativeIndex ai bp+ return (i, set0100) encodeI wbuf set 4 idx encodeS wbuf huff id set1 7 val @@ -171,7 +199,8 @@ -- not implemented -- 4.5.6. Literal Field Line Without Name Reference-encodeLiteralFieldLineWithoutNameReference :: WriteBuffer -> Token -> ByteString -> Bool -> IO ()+encodeLiteralFieldLineWithoutNameReference+ :: WriteBuffer -> Token -> ByteString -> Bool -> IO () encodeLiteralFieldLineWithoutNameReference wbuf token val huff = do let key = tokenFoldedKey token encodeS wbuf huff set0010 set00001 3 key
Network/QPACK/HeaderBlock/Prefix.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE BinaryLiterals #-} module Network.QPACK.HeaderBlock.Prefix (- -- * Prefix- encodePrefix- , decodePrefix- , encodeRequiredInsertCount- , decodeRequiredInsertCount- , encodeBase- , decodeBase- ) where+ -- * Prefix+ encodePrefix,+ decodePrefix,+ encodeRequiredInsertCount,+ decodeRequiredInsertCount,+ encodeBase,+ decodeBase,+) where import Network.ByteOrder import Network.HPACK.Internal@@ -27,7 +27,7 @@ -- >>> encodeRequiredInsertCount 128 1000 -- 233 encodeRequiredInsertCount :: Int -> InsertionPoint -> Int-encodeRequiredInsertCount _ 0 = 0+encodeRequiredInsertCount _ 0 = 0 encodeRequiredInsertCount maxEntries (InsertionPoint reqInsertCount) = (reqInsertCount `mod` (2 * maxEntries)) + 1 @@ -40,10 +40,11 @@ decodeRequiredInsertCount :: Int -> InsertionPoint -> Int -> InsertionPoint decodeRequiredInsertCount _ _ 0 = 0 decodeRequiredInsertCount maxEntries (InsertionPoint totalNumberOfInserts) encodedInsertCount- | encodedInsertCount > fullRange = E.impureThrow IllegalInsertCount- | reqInsertCount > maxValue && reqInsertCount <= fullRange = E.impureThrow IllegalInsertCount- | reqInsertCount > maxValue = InsertionPoint (reqInsertCount - fullRange)- | otherwise = InsertionPoint reqInsertCount+ | encodedInsertCount > fullRange = E.impureThrow IllegalInsertCount+ | reqInsertCount > maxValue && reqInsertCount <= fullRange =+ E.impureThrow IllegalInsertCount+ | reqInsertCount > maxValue = InsertionPoint (reqInsertCount - fullRange)+ | otherwise = InsertionPoint reqInsertCount where fullRange = 2 * maxEntries maxValue = totalNumberOfInserts + maxEntries@@ -59,8 +60,8 @@ -- (True,2) encodeBase :: InsertionPoint -> BasePoint -> (Bool, Int) encodeBase (InsertionPoint reqInsCnt) (BasePoint base)- | diff >= 0 = (False, diff) -- base - reqInsCnt- | otherwise = (True, negate diff - 1) -- reqInsCnt - base - 1+ | diff >= 0 = (False, diff) -- base - reqInsCnt+ | otherwise = (True, negate diff - 1) -- reqInsCnt - base - 1 where diff = base - reqInsCnt @@ -71,7 +72,7 @@ -- BasePoint 6 decodeBase :: InsertionPoint -> Bool -> Int -> BasePoint decodeBase (InsertionPoint reqInsCnt) False deltaBase = BasePoint (reqInsCnt + deltaBase)-decodeBase (InsertionPoint reqInsCnt) True deltaBase = BasePoint (reqInsCnt - deltaBase - 1)+decodeBase (InsertionPoint reqInsCnt) True deltaBase = BasePoint (reqInsCnt - deltaBase - 1) ---------------------------------------------------------------- @@ -81,14 +82,15 @@ encodePrefix wbuf dyntbl = do clearWriteBuffer wbuf maxEntries <- getMaxNumOfEntries dyntbl- baseIndex <- getBasePoint dyntbl- reqInsCnt <- getLargestReference dyntbl+ baseIndex <- getBasePoint dyntbl+ reqInsCnt <- getLargestReference dyntbl -- Required Insert Count let ric = encodeRequiredInsertCount maxEntries reqInsCnt encodeI wbuf set0 8 ric -- Sign bit + Delta Base (7+) let (s, base) = encodeBase reqInsCnt baseIndex- set | s = set1+ set+ | s = set1 | otherwise = set0 encodeI wbuf set 7 base @@ -105,5 +107,7 @@ w8'' = w8' .&. 0b01111111 delta <- decodeI 7 w8'' rbuf let baseIndex = decodeBase reqInsCnt s delta- qpackDebug dyntbl $ putStrLn $ "Required" ++ show reqInsCnt ++ ", " ++ show baseIndex- return (reqInsCnt,baseIndex)+ qpackDebug dyntbl $+ putStrLn $+ "Required" ++ show reqInsCnt ++ ", " ++ show baseIndex+ return (reqInsCnt, baseIndex)
Network/QPACK/Instruction.hs view
@@ -2,23 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QPACK.Instruction (- -- * Encoder instructions- HIndex(..)- , EncoderInstruction(..)- , InsIndex- , encodeEncoderInstructions- , decodeEncoderInstructions- , decodeEncoderInstructions'- , encodeEI- , decodeEI- -- * Decoder instructions- , DecoderInstruction(..)- , encodeDecoderInstructions- , decodeDecoderInstructions- , encodeDI- , decodeDI- ) where+ -- * Encoder instructions+ HIndex (..),+ EncoderInstruction (..),+ InsIndex,+ encodeEncoderInstructions,+ decodeEncoderInstructions,+ decodeEncoderInstructions',+ encodeEI,+ decodeEI, + -- * Decoder instructions+ DecoderInstruction (..),+ encodeDecoderInstructions,+ decodeDecoderInstructions,+ encodeDI,+ decodeDI,+) where+ import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive import Network.ByteOrder@@ -27,24 +28,36 @@ import qualified UnliftIO.Exception as E import Imports-import Network.QPACK.Types import Network.QPACK.Table.Static+import Network.QPACK.Types ---------------------------------------------------------------- type InsIndex = Either AbsoluteIndex InsRelativeIndex -data EncoderInstruction = SetDynamicTableCapacity Int- | InsertWithNameReference InsIndex HeaderValue- | InsertWithoutNameReference Token HeaderValue- | Duplicate InsRelativeIndex- deriving (Eq)+data EncoderInstruction+ = SetDynamicTableCapacity Int+ | InsertWithNameReference InsIndex HeaderValue+ | InsertWithoutNameReference Token HeaderValue+ | Duplicate InsRelativeIndex+ deriving (Eq) instance Show EncoderInstruction where show (SetDynamicTableCapacity n) = "SetDynamicTableCapacity " ++ show n- show (InsertWithNameReference (Left aidx) v) = "InsertWithNameReference \"" ++ BS8.unpack (entryHeaderName (toStaticEntry aidx)) ++ "\" \"" ++ BS8.unpack v ++ "\""- show (InsertWithNameReference (Right (InsRelativeIndex idx)) v) = "InsertWithNameReference (DynRel " ++ show idx ++ ") \"" ++ BS8.unpack v ++ "\""- show (InsertWithoutNameReference t v) = "InsertWithoutNameReference \"" ++ BS8.unpack (foldedCase (tokenKey t)) ++ "\" \"" ++ BS8.unpack v ++ "\""+ show (InsertWithNameReference (Left aidx) v) =+ "InsertWithNameReference \""+ ++ BS8.unpack (entryHeaderName (toStaticEntry aidx))+ ++ "\" \""+ ++ BS8.unpack v+ ++ "\""+ show (InsertWithNameReference (Right (InsRelativeIndex idx)) v) =+ "InsertWithNameReference (DynRel " ++ show idx ++ ") \"" ++ BS8.unpack v ++ "\""+ show (InsertWithoutNameReference t v) =+ "InsertWithoutNameReference \""+ ++ BS8.unpack (foldedCase (tokenKey t))+ ++ "\" \""+ ++ BS8.unpack v+ ++ "\"" show (Duplicate (InsRelativeIndex idx)) = "Duplicate (DynRel " ++ show idx ++ ")" ----------------------------------------------------------------@@ -54,72 +67,79 @@ mapM_ (encodeEI wbuf huff) eis encodeEI :: WriteBuffer -> Bool -> EncoderInstruction -> IO ()-encodeEI wbuf _ (SetDynamicTableCapacity cap) = encodeI wbuf set001 5 cap+encodeEI wbuf _ (SetDynamicTableCapacity cap) = encodeI wbuf set001 5 cap encodeEI wbuf huff (InsertWithNameReference hidx v) = do let (set, idx) = case hidx of- Left (AbsoluteIndex i) -> (set11, i)- Right (InsRelativeIndex i) -> (set1, i)+ Left (AbsoluteIndex i) -> (set11, i)+ Right (InsRelativeIndex i) -> (set1, i) encodeI wbuf set 6 idx encodeS wbuf huff id set1 7 v encodeEI wbuf huff (InsertWithoutNameReference k v) = do encodeS wbuf huff set01 set001 5 $ foldedCase $ tokenKey k- encodeS wbuf huff id set1 7 v-encodeEI wbuf _ (Duplicate (InsRelativeIndex idx)) = encodeI wbuf set000 5 idx+ encodeS wbuf huff id set1 7 v+encodeEI wbuf _ (Duplicate (InsRelativeIndex idx)) = encodeI wbuf set000 5 idx ---------------------------------------------------------------- -decodeEncoderInstructions' :: ByteString -> IO ([EncoderInstruction], ByteString)+decodeEncoderInstructions'+ :: ByteString -> IO ([EncoderInstruction], ByteString) decodeEncoderInstructions' bs = do let bufsiz = 4096 gcbuf <- mallocPlainForeignPtrBytes 4096 decodeEncoderInstructions (decodeH gcbuf bufsiz) bs -decodeEncoderInstructions :: HuffmanDecoder -> ByteString -> IO ([EncoderInstruction],ByteString)+decodeEncoderInstructions+ :: HuffmanDecoder -> ByteString -> IO ([EncoderInstruction], ByteString) decodeEncoderInstructions hufdec bs = withReadBuffer bs $ loop id where loop build rbuf = do n <- remainingSize rbuf- if n == 0 then do- let eis = build []- return (eis, "")- else do- save rbuf- er <- E.try $ decodeEI hufdec rbuf- case er of- Right r -> loop (build . (r :)) rbuf- Left BufferOverrun -> do- goBack rbuf- rn <- remainingSize rbuf- left <- extractByteString rbuf rn- let eis = build []- return (eis, left)+ if n == 0+ then do+ let eis = build []+ return (eis, "")+ else do+ save rbuf+ er <- E.try $ decodeEI hufdec rbuf+ case er of+ Right r -> loop (build . (r :)) rbuf+ Left BufferOverrun -> do+ goBack rbuf+ rn <- remainingSize rbuf+ left <- extractByteString rbuf rn+ let eis = build []+ return (eis, left) decodeEI :: HuffmanDecoder -> ReadBuffer -> IO EncoderInstruction decodeEI hufdec rbuf = do w8 <- read8 rbuf- if w8 `testBit` 7 then- decodeInsertWithNameReference rbuf w8 hufdec- else if w8 `testBit` 6 then- decodeInsertWithoutNameReference rbuf hufdec- else if w8 `testBit` 5 then- decodeSetDynamicTableCapacity rbuf w8- else- decodeDuplicate rbuf w8+ if w8 `testBit` 7+ then decodeInsertWithNameReference rbuf w8 hufdec+ else+ if w8 `testBit` 6+ then decodeInsertWithoutNameReference rbuf hufdec+ else+ if w8 `testBit` 5+ then decodeSetDynamicTableCapacity rbuf w8+ else decodeDuplicate rbuf w8 -decodeInsertWithNameReference :: ReadBuffer -> Word8 -> HuffmanDecoder -> IO EncoderInstruction+decodeInsertWithNameReference+ :: ReadBuffer -> Word8 -> HuffmanDecoder -> IO EncoderInstruction decodeInsertWithNameReference rbuf w8 hufdec = do idx <- decodeI 6 (w8 .&. 0b00111111) rbuf- let hidx | w8 `testBit` 6 = Left (AbsoluteIndex idx)- | otherwise = Right (InsRelativeIndex idx)+ let hidx+ | w8 `testBit` 6 = Left (AbsoluteIndex idx)+ | otherwise = Right (InsRelativeIndex idx) v <- decodeS (.&. 0b01111111) (`testBit` 7) 7 hufdec rbuf return $ InsertWithNameReference hidx v -decodeInsertWithoutNameReference :: ReadBuffer -> HuffmanDecoder -> IO EncoderInstruction+decodeInsertWithoutNameReference+ :: ReadBuffer -> HuffmanDecoder -> IO EncoderInstruction decodeInsertWithoutNameReference rbuf hufdec = do ff rbuf (-1) k <- decodeS (.&. 0b00011111) (`testBit` 5) 5 hufdec rbuf v <- decodeS (.&. 0b01111111) (`testBit` 7) 7 hufdec rbuf- return $ InsertWithoutNameReference (toToken k) v+ return $ InsertWithoutNameReference (toToken k) v decodeSetDynamicTableCapacity :: ReadBuffer -> Word8 -> IO EncoderInstruction decodeSetDynamicTableCapacity rbuf w8 =@@ -131,10 +151,11 @@ ---------------------------------------------------------------- -data DecoderInstruction = SectionAcknowledgement Int- | StreamCancellation Int- | InsertCountIncrement Int- deriving (Eq, Show)+data DecoderInstruction+ = SectionAcknowledgement Int+ | StreamCancellation Int+ | InsertCountIncrement Int+ deriving (Eq, Show) ---------------------------------------------------------------- @@ -143,37 +164,38 @@ mapM_ (encodeDI wbuf) dis encodeDI :: WriteBuffer -> DecoderInstruction -> IO ()-encodeDI wbuf (SectionAcknowledgement n) = encodeI wbuf set1 7 n-encodeDI wbuf (StreamCancellation n) = encodeI wbuf set01 6 n-encodeDI wbuf (InsertCountIncrement n) = encodeI wbuf id 6 n+encodeDI wbuf (SectionAcknowledgement n) = encodeI wbuf set1 7 n+encodeDI wbuf (StreamCancellation n) = encodeI wbuf set01 6 n+encodeDI wbuf (InsertCountIncrement n) = encodeI wbuf id 6 n ---------------------------------------------------------------- -decodeDecoderInstructions :: ByteString -> IO ([DecoderInstruction],ByteString)+decodeDecoderInstructions :: ByteString -> IO ([DecoderInstruction], ByteString) decodeDecoderInstructions bs = withReadBuffer bs $ loop id where loop build rbuf = do n <- remainingSize rbuf- if n == 0 then do- let dis = build []- return (dis, "")- else do- save rbuf- er <- E.try $ decodeDI rbuf- case er of- Right r -> loop (build . (r :)) rbuf- Left BufferOverrun -> do- goBack rbuf- rn <- remainingSize rbuf- left <- extractByteString rbuf rn- let dis = build []- return (dis, left)+ if n == 0+ then do+ let dis = build []+ return (dis, "")+ else do+ save rbuf+ er <- E.try $ decodeDI rbuf+ case er of+ Right r -> loop (build . (r :)) rbuf+ Left BufferOverrun -> do+ goBack rbuf+ rn <- remainingSize rbuf+ left <- extractByteString rbuf rn+ let dis = build []+ return (dis, left) decodeDI :: ReadBuffer -> IO DecoderInstruction decodeDI rbuf = do w8 <- read8 rbuf- if w8 `testBit` 7 then- SectionAcknowledgement <$> decodeI 7 (w8 .&. 0b01111111) rbuf- else do- i <- decodeI 6 (w8 .&. 0b00111111) rbuf- return $ if w8 `testBit` 6 then StreamCancellation i else InsertCountIncrement i+ if w8 `testBit` 7+ then SectionAcknowledgement <$> decodeI 7 (w8 .&. 0b01111111) rbuf+ else do+ i <- decodeI 6 (w8 .&. 0b00111111) rbuf+ return $ if w8 `testBit` 6 then StreamCancellation i else InsertCountIncrement i
Network/QPACK/Internal.hs view
@@ -1,12 +1,13 @@ module Network.QPACK.Internal (- module Network.QPACK.Error- , module Network.QPACK.Table- , module Network.QPACK.Instruction- , module Network.QPACK.HeaderBlock- , module Network.QPACK.HeaderBlock.Prefix- -- * Types- , module Network.QPACK.Types- ) where+ module Network.QPACK.Error,+ module Network.QPACK.Table,+ module Network.QPACK.Instruction,+ module Network.QPACK.HeaderBlock,+ module Network.QPACK.HeaderBlock.Prefix,++ -- * Types+ module Network.QPACK.Types,+) where import Network.QPACK.Error import Network.QPACK.HeaderBlock
Network/QPACK/Table.hs view
@@ -1,33 +1,37 @@ module Network.QPACK.Table (- -- * Dynamic table- DynamicTable- , newDynamicTableForEncoding- , newDynamicTableForDecoding- -- * Getter and setter- , getMaxNumOfEntries- , setBasePointToInsersionPoint- , getBasePoint- , getInsertionPoint- , getInsertionPointSTM- , checkInsertionPoint- , getLargestReference- , updateLargestReference- -- * Entry- , insertEntryToEncoder- , insertEntryToDecoder- , toIndexedEntry- -- * Reverse index- , RevIndex- , RevResult(..)- , getRevIndex- , lookupRevIndex- -- * Misc- , getHuffmanDecoder- , setDebugQPACK- , getDebugQPACK- , qpackDebug- ) where+ -- * Dynamic table+ DynamicTable,+ newDynamicTableForEncoding,+ newDynamicTableForDecoding, + -- * Getter and setter+ getMaxNumOfEntries,+ setBasePointToInsersionPoint,+ getBasePoint,+ getInsertionPoint,+ getInsertionPointSTM,+ checkInsertionPoint,+ getLargestReference,+ updateLargestReference,++ -- * Entry+ insertEntryToEncoder,+ insertEntryToDecoder,+ toIndexedEntry,++ -- * Reverse index+ RevIndex,+ RevResult (..),+ getRevIndex,+ lookupRevIndex,++ -- * Misc+ getHuffmanDecoder,+ setDebugQPACK,+ getDebugQPACK,+ qpackDebug,+) where+ import Control.Concurrent.STM import Network.HPACK.Internal (Entry) @@ -37,5 +41,5 @@ import Network.QPACK.Types toIndexedEntry :: DynamicTable -> HIndex -> STM Entry-toIndexedEntry _ (SIndex ai) = return $ toStaticEntry ai+toIndexedEntry _ (SIndex ai) = return $ toStaticEntry ai toIndexedEntry dyntbl (DIndex ai) = toDynamicEntry dyntbl ai
Network/QPACK/Table/Dynamic.hs view
@@ -1,10 +1,10 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.QPACK.Table.Dynamic where import Control.Concurrent.STM-import Data.Array.Base (unsafeWrite, unsafeRead)+import Data.Array.Base (unsafeRead, unsafeWrite) import Data.Array.MArray (newArray) import Data.IORef import Network.ByteOrder@@ -15,22 +15,23 @@ import Network.QPACK.Table.RevIndex import Network.QPACK.Types -data CodeInfo =- EncodeInfo RevIndex -- Reverse index- (IORef InsertionPoint)- | DecodeInfo HuffmanDecoder+data CodeInfo+ = EncodeInfo+ RevIndex -- Reverse index+ (IORef InsertionPoint)+ | DecodeInfo HuffmanDecoder -- | Dynamic table for QPACK.-data DynamicTable = DynamicTable {- codeInfo :: CodeInfo- , droppingPoint :: IORef AbsoluteIndex- , drainingPoint :: IORef AbsoluteIndex- , insertionPoint :: TVar InsertionPoint- , basePoint :: IORef BasePoint- , maxNumOfEntries :: TVar Int- , circularTable :: TVar Table- , debugQPACK :: IORef Bool- }+data DynamicTable = DynamicTable+ { codeInfo :: CodeInfo+ , droppingPoint :: IORef AbsoluteIndex+ , drainingPoint :: IORef AbsoluteIndex+ , insertionPoint :: TVar InsertionPoint+ , basePoint :: IORef BasePoint+ , maxNumOfEntries :: TVar Int+ , circularTable :: TVar Table+ , debugQPACK :: IORef Bool+ } type Table = TArray Index Entry @@ -58,8 +59,10 @@ ---------------------------------------------------------------- -- | Creating 'DynamicTable' for encoding.-newDynamicTableForEncoding :: Size -- ^ The dynamic table size- -> IO DynamicTable+newDynamicTableForEncoding+ :: Size+ -- ^ The dynamic table size+ -> IO DynamicTable newDynamicTableForEncoding maxsiz = do rev <- newRevIndex ref <- newIORef 0@@ -67,42 +70,47 @@ newDynamicTable maxsiz info -- | Creating 'DynamicTable' for decoding.-newDynamicTableForDecoding :: Size -- ^ The dynamic table size- -> Size -- ^ The size of temporary buffer for Huffman decoding- -> IO DynamicTable+newDynamicTableForDecoding+ :: Size+ -- ^ The dynamic table size+ -> Size+ -- ^ The size of temporary buffer for Huffman decoding+ -> IO DynamicTable newDynamicTableForDecoding maxsiz huftmpsiz = do gcbuf <- mallocPlainForeignPtrBytes huftmpsiz- tvar <- newTVarIO $ Just (gcbuf,huftmpsiz)+ tvar <- newTVarIO $ Just (gcbuf, huftmpsiz) let decoder = decodeHLock tvar info = DecodeInfo decoder newDynamicTable maxsiz info -decodeHLock :: TVar (Maybe (GCBuffer,Int)) -> ReadBuffer -> Int -> IO ByteString-decodeHLock tvar rbuf len = E.bracket lock unlock $ \(gcbuf,bufsiz) ->- withForeignPtr gcbuf $ \buf -> do- wbuf <- newWriteBuffer buf bufsiz- decH wbuf rbuf len- toByteString wbuf+decodeHLock+ :: TVar (Maybe (GCBuffer, Int)) -> ReadBuffer -> Int -> IO ByteString+decodeHLock tvar rbuf len = E.bracket lock unlock $ \(gcbuf, bufsiz) ->+ withForeignPtr gcbuf $ \buf -> do+ wbuf <- newWriteBuffer buf bufsiz+ decH wbuf rbuf len+ toByteString wbuf where lock = atomically $ do mx <- readTVar tvar case mx of- Nothing -> retry- Just x -> do- writeTVar tvar Nothing- return x+ Nothing -> retry+ Just x -> do+ writeTVar tvar Nothing+ return x unlock x = atomically $ writeTVar tvar $ Just x newDynamicTable :: Size -> CodeInfo -> IO DynamicTable newDynamicTable maxsiz info = do- tbl <- atomically $ newArray (0,end) dummyEntry- DynamicTable info <$> newIORef 0 -- droppingPoint- <*> newIORef 0 -- drainingPoint- <*> newTVarIO 0 -- insertionPoint- <*> newIORef 0 -- basePoint- <*> newTVarIO maxN -- maxNumOfEntries- <*> newTVarIO tbl -- maxDynamicTableSize- <*> newIORef False -- debugQPACK+ tbl <- atomically $ newArray (0, end) dummyEntry+ DynamicTable info+ <$> newIORef 0 -- droppingPoint+ <*> newIORef 0 -- drainingPoint+ <*> newTVarIO 0 -- insertionPoint+ <*> newIORef 0 -- basePoint+ <*> newTVarIO maxN -- maxNumOfEntries+ <*> newTVarIO tbl -- maxDynamicTableSize+ <*> newIORef False -- debugQPACK where maxN = maxNumbers maxsiz end = maxN - 1@@ -128,7 +136,7 @@ ---------------------------------------------------------------- {-# INLINE getRevIndex #-}-getRevIndex :: DynamicTable-> RevIndex+getRevIndex :: DynamicTable -> RevIndex getRevIndex DynamicTable{..} = rev where EncodeInfo rev _ = codeInfo
Network/QPACK/Table/RevIndex.hs view
@@ -2,15 +2,15 @@ {-# LANGUAGE RecordWildCards #-} module Network.QPACK.Table.RevIndex (- RevResult(..)- , RevIndex- , newRevIndex- , renewRevIndex- , lookupRevIndex- , lookupRevIndex'- , insertRevIndex- , deleteRevIndexList- ) where+ RevResult (..),+ RevIndex,+ newRevIndex,+ renewRevIndex,+ lookupRevIndex,+ lookupRevIndex',+ insertRevIndex,+ deleteRevIndexList,+) where import Data.Array (Array) import qualified Data.Array as A@@ -43,66 +43,76 @@ -- in Linear{H}. type OtherRevIdex = IORef (Map KeyValue HIndex) -{-# SPECIALIZE INLINE M.lookup :: KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex #-}-{-# SPECIALIZE INLINE M.delete :: KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}-{-# SPECIALIZE INLINE M.insert :: KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}+{-# SPECIALIZE INLINE M.lookup ::+ KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex+ #-}+{-# SPECIALIZE INLINE M.delete ::+ KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex+ #-}+{-# SPECIALIZE INLINE M.insert ::+ KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex+ #-} ---------------------------------------------------------------- type StaticRevIndex = Array Int StaticEntry -data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving Show+data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show) type ValueMap = Map HeaderValue HIndex ---------------------------------------------------------------- staticRevIndex :: StaticRevIndex-staticRevIndex = A.array (minTokenIx,51) $ map toEnt zs+staticRevIndex = A.array (minTokenIx, 51) $ map toEnt zs where toEnt (k, xs) = (quicIx $ tokenIx $ toToken k, m) where m = case xs of- [] -> error "staticRevIndex"- [("",i)] -> StaticEntry i Nothing- (_,i):_ -> StaticEntry i $ Just $ M.fromList xs+ [] -> error "staticRevIndex"+ [("", i)] -> StaticEntry i Nothing+ (_, i) : _ -> StaticEntry i $ Just $ M.fromList xs zs = map extract $ groupBy ((==) `on` fst) $ sort lst where- lst = zipWith (\(k,v) i -> (k,(v,i))) staticTableList $ map (SIndex . AbsoluteIndex) [0..]+ lst =+ zipWith (\(k, v) i -> (k, (v, i))) staticTableList $+ map (SIndex . AbsoluteIndex) [0 ..] extract xs = (fst (head xs), map snd xs) {-# INLINE lookupStaticRevIndex #-} lookupStaticRevIndex :: Int -> HeaderValue -> RevResult lookupStaticRevIndex ix v = case staticRevIndex `unsafeAt` ix of- StaticEntry i Nothing -> K i+ StaticEntry i Nothing -> K i StaticEntry i (Just m) -> case M.lookup v m of- Nothing -> K i- Just j -> KV j+ Nothing -> K i+ Just j -> KV j ---------------------------------------------------------------- newDynamicRevIndex :: IO DynamicRevIndex-newDynamicRevIndex = A.listArray (minTokenIx,maxStaticTokenIx) <$> mapM mk lst+newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk lst where mk _ = newIORef M.empty- lst = [minTokenIx..maxStaticTokenIx]+ lst = [minTokenIx .. maxStaticTokenIx] renewDynamicRevIndex :: DynamicRevIndex -> IO ()-renewDynamicRevIndex drev = mapM_ clear [minTokenIx..maxStaticTokenIx]+renewDynamicRevIndex drev = mapM_ clear [minTokenIx .. maxStaticTokenIx] where clear t = writeIORef (drev `unsafeAt` t) M.empty {-# INLINE lookupDynamicStaticRevIndex #-}-lookupDynamicStaticRevIndex :: Int -> HeaderValue -> DynamicRevIndex -> IO RevResult+lookupDynamicStaticRevIndex+ :: Int -> HeaderValue -> DynamicRevIndex -> IO RevResult lookupDynamicStaticRevIndex ix v drev = do let ref = drev `unsafeAt` ix m <- readIORef ref case M.lookup v m of- Just i -> return $ KV i+ Just i -> return $ KV i Nothing -> return $ lookupStaticRevIndex ix v {-# INLINE insertDynamicRevIndex #-}-insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()+insertDynamicRevIndex+ :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i where ref = drev `unsafeAt` tokenIx t@@ -123,11 +133,11 @@ {-# INLINE lookupOtherRevIndex #-} lookupOtherRevIndex :: Header -> OtherRevIdex -> IO RevResult-lookupOtherRevIndex (k,v) ref = do- oth <- readIORef ref- case M.lookup (KeyValue k v) oth of+lookupOtherRevIndex (k, v) ref = do+ oth <- readIORef ref+ case M.lookup (KeyValue k v) oth of Nothing -> return N- Just i -> return $ KV i+ Just i -> return $ KV i {-# INLINE insertOtherRevIndex #-} insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()@@ -152,29 +162,33 @@ renewOtherRevIndex oth {-# INLINE lookupRevIndex #-}-lookupRevIndex :: Token- -> HeaderValue- -> RevIndex- -> IO RevResult+lookupRevIndex+ :: Token+ -> HeaderValue+ -> RevIndex+ -> IO RevResult lookupRevIndex t@Token{..} v (RevIndex dyn oth)- | ix < 0 = lookupOtherRevIndex (k,v) oth- | shouldBeIndexed = lookupDynamicStaticRevIndex ix v dyn- -- path: is not indexed but ":path /" should be used, sigh.- | otherwise = return $ lookupStaticRevIndex ix v+ | ix < 0 = lookupOtherRevIndex (k, v) oth+ | shouldBeIndexed = lookupDynamicStaticRevIndex ix v dyn+ -- path: is not indexed but ":path /" should be used, sigh.+ | otherwise = return $ lookupStaticRevIndex ix v where ix = quicIx tokenIx k = tokenFoldedKey t+ -- ent = toEntryToken t v -- fixme {-# INLINE lookupRevIndex' #-}-lookupRevIndex' :: Token- -> HeaderValue- -> RevResult+lookupRevIndex'+ :: Token+ -> HeaderValue+ -> RevResult lookupRevIndex' Token{..} v- | ix >= 0 = lookupStaticRevIndex ix v- | otherwise = N -- fixme+ | ix >= 0 = lookupStaticRevIndex ix v+ | otherwise = N -- fixme where ix = quicIx tokenIx+ -- k = tokenFoldedKey t -- fixme ----------------------------------------------------------------@@ -182,14 +196,14 @@ {-# INLINE insertRevIndex #-} insertRevIndex :: Entry -> HIndex -> RevIndex -> IO () insertRevIndex (Entry _ t v) i (RevIndex dyn oth)- | quicIx (tokenIx t) >= 0 = insertDynamicRevIndex t v i dyn- | otherwise = insertOtherRevIndex t v i oth+ | quicIx (tokenIx t) >= 0 = insertDynamicRevIndex t v i dyn+ | otherwise = insertOtherRevIndex t v i oth {-# INLINE deleteRevIndex #-} deleteRevIndex :: RevIndex -> Entry -> IO () deleteRevIndex (RevIndex dyn oth) (Entry _ t v)- | quicIx (tokenIx t) >= 0 = deleteDynamicRevIndex t v dyn- | otherwise = deleteOtherRevIndex t v oth+ | quicIx (tokenIx t) >= 0 = deleteDynamicRevIndex t v dyn+ | otherwise = deleteOtherRevIndex t v oth {-# INLINE deleteRevIndexList #-} deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
Network/QPACK/Table/Static.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QPACK.Table.Static (- toStaticEntry- , staticTableSize- , staticTableList- ) where+ toStaticEntry,+ staticTableSize,+ staticTableList,+) where import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt)@@ -21,6 +21,7 @@ staticTableSize = length staticTableList {-# INLINE toStaticEntry #-}+ -- | Get 'Entry' from the static table. -- -- >>> toStaticEntry 1@@ -31,114 +32,117 @@ -- Entry 53 (Token {tokenIx = 21, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Type"}) "image/png" toStaticEntry :: AbsoluteIndex -> Entry toStaticEntry (AbsoluteIndex sidx)- | sidx < staticTableSize = staticTable `unsafeAt` sidx- | otherwise = E.impureThrow IllegalStaticIndex+ | sidx < staticTableSize = staticTable `unsafeAt` sidx+ | otherwise = E.impureThrow IllegalStaticIndex -- | Pre-defined static table. staticTable :: Array Index Entry-staticTable = listArray (1,staticTableSize) $ map toEntry staticTableList+staticTable = listArray (1, staticTableSize) $ map toEntry staticTableList ---------------------------------------------------------------- staticTableList :: [Header]-staticTableList = [- (":authority", "")- , (":path", "/")- , ("age", "0")- , ("content-disposition", "")- , ("content-length", "0")- , ("cookie", "")- , ("date", "")- , ("etag", "")- , ("if-modified-since", "")- , ("if-none-match", "")- , ("last-modified", "")- , ("link", "")- , ("location", "")- , ("referer", "")- , ("set-cookie", "")- , (":method", "CONNECT")- , (":method", "DELETE")- , (":method", "GET")- , (":method", "HEAD")- , (":method", "OPTIONS")- , (":method", "POST")- , (":method", "PUT")- , (":scheme", "http")- , (":scheme", "https")- , (":status", "103")- , (":status", "200")- , (":status", "304")- , (":status", "404")- , (":status", "503")- , ("accept", "*/*")- , ("accept", "application/dns-message")- , ("accept-encoding", "gzip, deflate, br")- , ("accept-ranges", "bytes")- , ("access-control-allow-headers", "cache-control")- , ("access-control-allow-headers", "content-type")- , ("access-control-allow-origin", "*")- , ("cache-control", "max-age=0")- , ("cache-control", "max-age=2592000")- , ("cache-control", "max-age=604800")- , ("cache-control", "no-cache")- , ("cache-control", "no-store")- , ("cache-control", "public, age=31536000")- , ("content-encoding", "br")- , ("content-encoding", "gzip")- , ("content-type", "application/dns-message")- , ("content-type", "application/javascript")- , ("content-type", "application/json")- , ("content-type", "application/x-www-form-urlencoded")- , ("content-type", "image/gif")- , ("content-type", "image/jpeg")- , ("content-type", "image/png")- , ("content-type", "text/css")- , ("content-type", "text/html; charset=utf-8")- , ("content-type", "text/plain")- , ("content-type", "text/plain;charset=utf-8")- , ("range", "bytes=0-")- , ("strict-transport-security", "max-age=31536000")- , ("strict-transport-security", "max-age=31536000; includesubdomains")- , ("strict-transport-security", "max-age=31536000; includesubdomains; preload")- , ("vary", "accept-encoding")- , ("vary", "origin")- , ("x-content-type-options", "nosniff")- , ("x-xss-protection", "1; mode=block")- , (":status", "100")- , (":status", "204")- , (":status", "206")- , (":status", "302")- , (":status", "400")- , (":status", "403")- , (":status", "421")- , (":status", "425")- , (":status", "500")- , ("accept-language", "")- , ("access-control-allow-credentials", "FALSE")- , ("access-control-allow-credentials", "TRUE")- , ("access-control-allow-headers", "*")- , ("access-control-allow-methods", "get")- , ("access-control-allow-methods", "get, post, options")- , ("access-control-allow-methods", "options")- , ("access-control-expose-headers", "content-length")- , ("access-control-request-headers", "content-type")- , ("access-control-request-method", "get")- , ("access-control-request-method", "post")- , ("alt-svc", "clear")- , ("authorization", "")- , ("content-security-policy", "script-src 'none'; object-src 'none'; base-uri 'none'")- , ("early-data", "1")- , ("expect-ct", "")- , ("forwarded", "")- , ("if-range", "")- , ("origin", "")- , ("purpose", "prefetch")- , ("server", "")- , ("timing-allow-origin", "*")- , ("upgrade-insecure-requests", "1")- , ("user-agent", "")- , ("x-forwarded-for", "")- , ("x-frame-options", "deny")- , ("x-frame-options", "sameorigin")- ]+staticTableList =+ [ (":authority", "")+ , (":path", "/")+ , ("age", "0")+ , ("content-disposition", "")+ , ("content-length", "0")+ , ("cookie", "")+ , ("date", "")+ , ("etag", "")+ , ("if-modified-since", "")+ , ("if-none-match", "")+ , ("last-modified", "")+ , ("link", "")+ , ("location", "")+ , ("referer", "")+ , ("set-cookie", "")+ , (":method", "CONNECT")+ , (":method", "DELETE")+ , (":method", "GET")+ , (":method", "HEAD")+ , (":method", "OPTIONS")+ , (":method", "POST")+ , (":method", "PUT")+ , (":scheme", "http")+ , (":scheme", "https")+ , (":status", "103")+ , (":status", "200")+ , (":status", "304")+ , (":status", "404")+ , (":status", "503")+ , ("accept", "*/*")+ , ("accept", "application/dns-message")+ , ("accept-encoding", "gzip, deflate, br")+ , ("accept-ranges", "bytes")+ , ("access-control-allow-headers", "cache-control")+ , ("access-control-allow-headers", "content-type")+ , ("access-control-allow-origin", "*")+ , ("cache-control", "max-age=0")+ , ("cache-control", "max-age=2592000")+ , ("cache-control", "max-age=604800")+ , ("cache-control", "no-cache")+ , ("cache-control", "no-store")+ , ("cache-control", "public, age=31536000")+ , ("content-encoding", "br")+ , ("content-encoding", "gzip")+ , ("content-type", "application/dns-message")+ , ("content-type", "application/javascript")+ , ("content-type", "application/json")+ , ("content-type", "application/x-www-form-urlencoded")+ , ("content-type", "image/gif")+ , ("content-type", "image/jpeg")+ , ("content-type", "image/png")+ , ("content-type", "text/css")+ , ("content-type", "text/html; charset=utf-8")+ , ("content-type", "text/plain")+ , ("content-type", "text/plain;charset=utf-8")+ , ("range", "bytes=0-")+ , ("strict-transport-security", "max-age=31536000")+ , ("strict-transport-security", "max-age=31536000; includesubdomains")+ , ("strict-transport-security", "max-age=31536000; includesubdomains; preload")+ , ("vary", "accept-encoding")+ , ("vary", "origin")+ , ("x-content-type-options", "nosniff")+ , ("x-xss-protection", "1; mode=block")+ , (":status", "100")+ , (":status", "204")+ , (":status", "206")+ , (":status", "302")+ , (":status", "400")+ , (":status", "403")+ , (":status", "421")+ , (":status", "425")+ , (":status", "500")+ , ("accept-language", "")+ , ("access-control-allow-credentials", "FALSE")+ , ("access-control-allow-credentials", "TRUE")+ , ("access-control-allow-headers", "*")+ , ("access-control-allow-methods", "get")+ , ("access-control-allow-methods", "get, post, options")+ , ("access-control-allow-methods", "options")+ , ("access-control-expose-headers", "content-length")+ , ("access-control-request-headers", "content-type")+ , ("access-control-request-method", "get")+ , ("access-control-request-method", "post")+ , ("alt-svc", "clear")+ , ("authorization", "")+ ,+ ( "content-security-policy"+ , "script-src 'none'; object-src 'none'; base-uri 'none'"+ )+ , ("early-data", "1")+ , ("expect-ct", "")+ , ("forwarded", "")+ , ("if-range", "")+ , ("origin", "")+ , ("purpose", "prefetch")+ , ("server", "")+ , ("timing-allow-origin", "*")+ , ("upgrade-insecure-requests", "1")+ , ("user-agent", "")+ , ("x-forwarded-for", "")+ , ("x-frame-options", "deny")+ , ("x-frame-options", "sameorigin")+ ]
Network/QPACK/Token.hs view
@@ -1,15 +1,90 @@ module Network.QPACK.Token (- quicIx- ) where+ quicIx,+) where import Data.Array import Data.Array.Base (unsafeAt) hpack2QpackList :: [Int]-hpack2QpackList = [0,15,1,16,17,-1,19,31,20,18,22,2,-1,38,23,3,24,-1,4,-1,-1,25,5,6,7,-1,-1,-1,-1,-1,8,9,43,-1,10,11,12,-1,-1,-1,26,13,-1,-1,46,14,27,-1,49,28,-1,-1,-1,-1,32,21,33,34,35,36,37,39,40,41,42,44,45,47,48,29,50,51,30,-1]+hpack2QpackList =+ [ 0+ , 15+ , 1+ , 16+ , 17+ , -1+ , 19+ , 31+ , 20+ , 18+ , 22+ , 2+ , -1+ , 38+ , 23+ , 3+ , 24+ , -1+ , 4+ , -1+ , -1+ , 25+ , 5+ , 6+ , 7+ , -1+ , -1+ , -1+ , -1+ , -1+ , 8+ , 9+ , 43+ , -1+ , 10+ , 11+ , 12+ , -1+ , -1+ , -1+ , 26+ , 13+ , -1+ , -1+ , 46+ , 14+ , 27+ , -1+ , 49+ , 28+ , -1+ , -1+ , -1+ , -1+ , 32+ , 21+ , 33+ , 34+ , 35+ , 36+ , 37+ , 39+ , 40+ , 41+ , 42+ , 44+ , 45+ , 47+ , 48+ , 29+ , 50+ , 51+ , 30+ , -1+ ] hpack2QpackTable :: Array Int Int-hpack2QpackTable = listArray (0,length hpack2QpackList - 1) hpack2QpackList+hpack2QpackTable = listArray (0, length hpack2QpackList - 1) hpack2QpackList quicIx :: Int -> Int quicIx ix = hpack2QpackTable `unsafeAt` ix
Network/QPACK/Types.hs view
@@ -5,17 +5,19 @@ import Imports -newtype AbsoluteIndex = AbsoluteIndex Int deriving (Eq, Ord, Show, Num)+newtype AbsoluteIndex = AbsoluteIndex Int deriving (Eq, Ord, Show, Num) newtype InsRelativeIndex = InsRelativeIndex Int deriving (Eq, Ord, Show, Num)-newtype HBRelativeIndex = HBRelativeIndex Int deriving (Eq, Ord, Show, Num)-newtype PostBaseIndex = PostBaseIndex Int deriving (Eq, Ord, Show, Num)-newtype InsertionPoint = InsertionPoint Int deriving (Eq, Ord, Show, Num)-newtype BasePoint = BasePoint Int deriving (Eq, Ord, Show, Num)+newtype HBRelativeIndex = HBRelativeIndex Int deriving (Eq, Ord, Show, Num)+newtype PostBaseIndex = PostBaseIndex Int deriving (Eq, Ord, Show, Num)+newtype InsertionPoint = InsertionPoint Int deriving (Eq, Ord, Show, Num)+newtype BasePoint = BasePoint Int deriving (Eq, Ord, Show, Num) -data HIndex = SIndex AbsoluteIndex- | DIndex AbsoluteIndex- deriving (Eq, Ord, Show)+data HIndex+ = SIndex AbsoluteIndex+ | DIndex AbsoluteIndex+ deriving (Eq, Ord, Show) +{- FOURMOLU_DISABLE -} {- Dropping Draining Index Insertion Point | | |@@ -39,6 +41,7 @@ | 0 | 1 | Post-Base bp = 98 -}+{- FOURMOLU_ENABLE -} -- | --@@ -108,11 +111,21 @@ fromPostBaseIndex (PostBaseIndex pix) (BasePoint bp) = AbsoluteIndex (pix + bp) - type Setter = Word8 -> Word8 -set1, set01, set10, set11, set001, set0001, set0100, set0101, set0010, set00001:: Setter+set1+ , set01+ , set10+ , set11+ , set001+ , set0001+ , set0100+ , set0101+ , set0010+ , set00001+ :: Setter +{- FOURMOLU_DISABLE -} set1 = (`setBit` 7) set01 = (`setBit` 6) set10 = (`setBit` 7)@@ -130,3 +143,4 @@ set00 = id set000 = id set0000 = id+{- FOURMOLU_ENABLE -}
http3.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: http3-version: 0.0.6+version: 0.0.7 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -81,11 +81,11 @@ bytestring, case-insensitive, containers,- http2 >=4.2.0 && <5,+ http2 >=5.0 && <5.1, http-types, network, network-byte-order,- quic >= 0.1.2,+ quic >= 0.1.11 && < 0.2, sockaddr, stm, time-manager,
test/HTTP3/Error.hs view
@@ -36,7 +36,7 @@ where us = ms * 1000 client :: H3.Client ()- client sendRequest = do+ client sendRequest _aux = do let req = H3.requestNoBody methodGet "/" [] ret <- sendRequest req $ \_rsp -> return () threadDelay 100000
test/HTTP3/ServerSpec.hs view
@@ -30,33 +30,33 @@ C.run conn testH3ClientConfig conf client where client :: C.Client ()- client sendRequest = foldr1 concurrently_ [- client0 sendRequest- , client1 sendRequest- , client2 sendRequest- , client3 sendRequest+ client sendRequest _aux = foldr1 concurrently_ [+ client0 sendRequest _aux+ , client1 sendRequest _aux+ , client2 sendRequest _aux+ , client3 sendRequest _aux ] client0 :: C.Client ()-client0 sendRequest = do+client0 sendRequest _aux = do let req = C.requestNoBody methodGet "/" [] sendRequest req $ \rsp -> do C.responseStatus rsp `shouldBe` Just ok200 client1 :: C.Client ()-client1 sendRequest = do+client1 sendRequest _aux = do let req = C.requestNoBody methodGet "/something" [] sendRequest req $ \rsp -> do C.responseStatus rsp `shouldBe` Just notFound404 client2 :: C.Client ()-client2 sendRequest = do+client2 sendRequest _aux = do let req = C.requestNoBody methodPut "/" [] sendRequest req $ \rsp -> do C.responseStatus rsp `shouldBe` Just methodNotAllowed405 client3 :: C.Client ()-client3 sendRequest = do+client3 sendRequest _aux = do let req0 = C.requestFile methodPost "/echo" [] $ FileSpec "test/inputFile" 0 1012731 req = C.setRequestTrailersMaker req0 maker sendRequest req $ \rsp -> do
util/ClientX.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} {-# LANGUAGE StrictData #-}-{-# LANGUAGE RankNTypes #-} module ClientX where @@ -17,32 +17,39 @@ import qualified Network.HQ.Client as HQ import qualified Network.HTTP3.Client as H3 -data Aux = Aux {- auxPath :: String- , auxAuthority :: String- , auxDebug :: String -> IO ()- , auxShow :: ByteString -> IO ()- , auxCheckClose :: IO Bool- }+data Aux = Aux+ { auxPath :: String+ , auxAuthority :: String+ , auxDebug :: String -> IO ()+ , auxShow :: ByteString -> IO ()+ , auxCheckClose :: IO Bool+ } type Cli = Aux -> Connection -> IO () - clientHQ :: Int -> Cli clientHQ n = clientX n HQ.run clientH3 :: Int -> Cli clientH3 n = clientX n H3.run -clientX :: Int -> (Connection -> H3.ClientConfig -> H3.Config -> H3.Client () -> IO ()) -> Cli+clientX+ :: Int+ -> (Connection -> H3.ClientConfig -> H3.Config -> H3.Client () -> IO ())+ -> Cli clientX n0 run Aux{..} conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> run conn cliconf conf client where- req = H3.requestNoBody methodGet (C8.pack auxPath) [("User-Agent", "HaskellQuic/0.0.0")]- cliconf = H3.ClientConfig {- scheme = "https"- , authority = C8.pack auxAuthority- }- client sendRequest = loop n0+ req =+ H3.requestNoBody+ methodGet+ (C8.pack auxPath)+ [("User-Agent", "HaskellQuic/0.0.0")]+ cliconf =+ H3.ClientConfig+ { scheme = "https"+ , authority = C8.pack auxAuthority+ }+ client sendRequest _aux = loop n0 where loop 0 = return () loop n = do@@ -52,13 +59,14 @@ consume rsp auxShow "------------------------" when (n /= 1) $ do- threadDelay 1000000+ threadDelay 100000 loop (n - 1) consume rsp = do bs <- H3.getResponseBodyChunk rsp- if bs == "" then do- auxDebug "Fin received"- else do- auxShow bs- auxDebug $ show (C8.length bs) ++ " bytes received"- consume rsp+ if bs == ""+ then do+ auxDebug "Fin received"+ else do+ auxShow bs+ auxDebug $ show (C8.length bs) ++ " bytes received"+ consume rsp
util/Common.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Common (- getGroups- , getLogger- , makeProtos- ) where+ getGroups,+ getLogger,+ makeProtos,+) where import Data.Bits import Data.ByteString (ByteString)@@ -22,32 +22,32 @@ , ("ffdhe4096", FFDHE4096) , ("ffdhe6144", FFDHE6144) , ("ffdhe8192", FFDHE8192)- , ("p256", P256)- , ("p384", P384)- , ("p521", P521)- , ("x25519", X25519)- , ("x448", X448)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448) ] getGroups :: [Group] -> Maybe String -> [Group]-getGroups grps Nothing = grps-getGroups _ (Just gs) = mapMaybe (`lookup` namedGroups) $ split ',' gs+getGroups grps Nothing = grps+getGroups _ (Just gs) = mapMaybe (`lookup` namedGroups) $ split ',' gs split :: Char -> String -> [String] split _ "" = []-split c s = case break (c==) s of- ("",r) -> split c (tail r)- (s',"") -> [s']- (s',r) -> s' : split c (tail r)+split c s = case break (c ==) s of+ ("", r) -> split c (tail r)+ (s', "") -> [s']+ (s', r) -> s' : split c (tail r) getLogger :: Maybe FilePath -> (String -> IO ())-getLogger Nothing = \_ -> return ()+getLogger Nothing = \_ -> return () getLogger (Just file) = \msg -> appendFile file (msg ++ "\n") makeProtos :: Version -> (ByteString, ByteString)-makeProtos Version1 = ("h3","hq-interop")-makeProtos Version2 = ("h3","hq-interop")-makeProtos ver = (h3X,hqX)+makeProtos Version1 = ("h3", "hq-interop")+makeProtos Version2 = ("h3", "hq-interop")+makeProtos ver = (h3X, hqX) where verbs = C8.pack $ show $ fromVersion ver h3X = "h3-" `BS.append` verbs
util/ServerX.hs view
@@ -19,11 +19,13 @@ serverH3 :: Connection -> IO () serverH3 = serverX H3.run -serverX :: (Connection -> H3.Config -> H3.Server -> IO ()) -> Connection -> IO ()+serverX+ :: (Connection -> H3.Config -> H3.Server -> IO ()) -> Connection -> IO () serverX run conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf ->- run conn conf $ \_req _aux sendResponse -> do- let hdr = [ ("Content-Type", "text/html; charset=utf-8")- , ("Server", "HaskellQuic/0.0.0")- ]- rsp = H3.responseBuilder H.ok200 hdr "Hello, world!"- sendResponse rsp []+ run conn conf $ \_req _aux sendResponse -> do+ let hdr =+ [ ("Content-Type", "text/html; charset=utf-8")+ , ("Server", "HaskellQuic/0.0.0")+ ]+ rsp = H3.responseBuilder H.ok200 hdr "Hello, world!"+ sendResponse rsp []
util/client.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-}@@ -18,6 +19,7 @@ import System.Exit import System.IO import Text.Printf+import qualified UnliftIO.Timeout as T import ClientX import Common@@ -25,118 +27,162 @@ import Network.QUIC.Client import Network.QUIC.Internal hiding (RTT0) -data Options = Options {- optDebugLog :: Bool- , optShow :: Bool- , optQLogDir :: Maybe FilePath- , optKeyLogFile :: Maybe FilePath- , optGroups :: Maybe String- , optValidate :: Bool- , optHQ :: Bool- , optVerNego :: Bool- , optResumption :: Bool- , opt0RTT :: Bool- , optRetry :: Bool- , optQuantum :: Bool- , optInteractive :: Bool- , optMigration :: Maybe ConnectionControl- , optPacketSize :: Maybe Int- , optPerformance :: Word64- , optNumOfReqs :: Int- , optUnconSock :: Bool- } deriving Show+data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optQLogDir :: Maybe FilePath+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: Maybe String+ , optValidate :: Bool+ , optHQ :: Bool+ , optVerNego :: Bool+ , optResumption :: Bool+ , opt0RTT :: Bool+ , optRetry :: Bool+ , optQuantum :: Bool+ , optInteractive :: Bool+ , optMigration :: Maybe ConnectionControl+ , optPacketSize :: Maybe Int+ , optPerformance :: Word64+ , optNumOfReqs :: Int+ , optUnconSock :: Bool+ }+ deriving (Show) defaultOptions :: Options-defaultOptions = Options {- optDebugLog = False- , optShow = False- , optQLogDir = Nothing- , optKeyLogFile = Nothing- , optGroups = Nothing- , optHQ = False- , optValidate = False- , optVerNego = False- , optResumption = False- , opt0RTT = False- , optRetry = False- , optQuantum = False- , optInteractive = False- , optMigration = Nothing- , optPacketSize = Nothing- , optPerformance = 0- , optNumOfReqs = 1- , optUnconSock = True- }+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optQLogDir = Nothing+ , optKeyLogFile = Nothing+ , optGroups = Nothing+ , optHQ = False+ , optValidate = False+ , optVerNego = False+ , optResumption = False+ , opt0RTT = False+ , optRetry = False+ , optQuantum = False+ , optInteractive = False+ , optMigration = Nothing+ , optPacketSize = Nothing+ , optPerformance = 0+ , optNumOfReqs = 1+ , optUnconSock = True+ } usage :: String usage = "Usage: client [OPTION] addr port" options :: [OptDescr (Options -> Options)]-options = [- Option ['d'] ["debug"]- (NoArg (\o -> o { optDebugLog = True }))- "print debug info"- , Option ['v'] ["show-content"]- (NoArg (\o -> o { optShow = True }))- "print downloaded content"- , Option ['q'] ["qlog-dir"]- (ReqArg (\dir o -> o { optQLogDir = Just dir }) "<dir>")- "directory to store qlog"- , Option ['l'] ["key-log-file"]- (ReqArg (\file o -> o { optKeyLogFile = Just file }) "<file>")- "a file to store negotiated secrets"- , Option ['g'] ["groups"]- (ReqArg (\gs o -> o { optGroups = Just gs }) "<groups>")- "specify groups"- , Option ['c'] ["validate"]- (NoArg (\o -> o { optValidate = True }))- "validate server's certificate"- , Option ['r'] ["hq"]- (NoArg (\o -> o { optHQ = True }))- "prefer hq (HTTP/0.9)"- , Option ['s'] ["packet-size"]- (ReqArg (\n o -> o { optPacketSize = Just (read n) }) "<size>")- "specify QUIC packet size (UDP payload size)"- , Option ['i'] ["interactive"]- (NoArg (\o -> o { optInteractive = True }))- "prefer hq (HTTP/0.9)"- , Option ['V'] ["vernego"]- (NoArg (\o -> o { optVerNego = True }))- "try version negotiation"- , Option ['R'] ["resumption"]- (NoArg (\o -> o { optResumption = True }))- "try session resumption"- , Option ['Z'] ["0rtt"]- (NoArg (\o -> o { opt0RTT = True }))- "try sending early data"- , Option ['S'] ["stateless-retry"]- (NoArg (\o -> o { optRetry = True }))- "check stateless retry"- , Option ['Q'] ["quantum"]- (NoArg (\o -> o { optQuantum = True }))- "try sending large Initials"- , Option ['M'] ["change-server-cid"]- (NoArg (\o -> o { optMigration = Just ChangeServerCID }))- "use a new server CID"- , Option ['N'] ["change-client-cid"]- (NoArg (\o -> o { optMigration = Just ChangeClientCID }))- "use a new client CID"- , Option ['B'] ["nat-rebinding"]- (NoArg (\o -> o { optMigration = Just NATRebinding }))- "use a new local port"- , Option ['A'] ["address-mobility"]- (NoArg (\o -> o { optMigration = Just ActiveMigration }))- "use a new address and a new server CID"- , Option ['t'] ["performance"]- (ReqArg (\n o -> o { optPerformance = read n }) "<size>")- "measure performance"- , Option ['n'] ["number-of-requests"]- (ReqArg (\n o -> o { optNumOfReqs = read n }) "<n>")- "specify the number of requests"- , Option ['m'] ["use-connected-socket"]- (NoArg (\o -> o { optUnconSock = False }))- "use connected sockets instead of unconnected sockets"- ]+options =+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['q']+ ["qlog-dir"]+ (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")+ "directory to store qlog"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")+ "specify groups"+ , Option+ ['c']+ ["validate"]+ (NoArg (\o -> o{optValidate = True}))+ "validate server's certificate"+ , Option+ ['r']+ ["hq"]+ (NoArg (\o -> o{optHQ = True}))+ "prefer hq (HTTP/0.9)"+ , Option+ ['s']+ ["packet-size"]+ (ReqArg (\n o -> o{optPacketSize = Just (read n)}) "<size>")+ "specify QUIC packet size (UDP payload size)"+ , Option+ ['i']+ ["interactive"]+ (NoArg (\o -> o{optInteractive = True}))+ "prefer hq (HTTP/0.9)"+ , Option+ ['V']+ ["vernego"]+ (NoArg (\o -> o{optVerNego = True}))+ "try version negotiation"+ , Option+ ['R']+ ["resumption"]+ (NoArg (\o -> o{optResumption = True}))+ "try session resumption"+ , Option+ ['Z']+ ["0rtt"]+ (NoArg (\o -> o{opt0RTT = True}))+ "try sending early data"+ , Option+ ['S']+ ["stateless-retry"]+ (NoArg (\o -> o{optRetry = True}))+ "check stateless retry"+ , Option+ ['Q']+ ["quantum"]+ (NoArg (\o -> o{optQuantum = True}))+ "try sending large Initials"+ , Option+ ['M']+ ["change-server-cid"]+ (NoArg (\o -> o{optMigration = Just ChangeServerCID}))+ "use a new server CID"+ , Option+ ['N']+ ["change-client-cid"]+ (NoArg (\o -> o{optMigration = Just ChangeClientCID}))+ "use a new client CID"+ , Option+ ['B']+ ["nat-rebinding"]+ (NoArg (\o -> o{optMigration = Just NATRebinding}))+ "use a new local port"+ , Option+ ['A']+ ["address-mobility"]+ (NoArg (\o -> o{optMigration = Just ActiveMigration}))+ "use a new address and a new server CID"+ , Option+ ['t']+ ["performance"]+ (ReqArg (\n o -> o{optPerformance = read n}) "<size>")+ "measure performance"+ , Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")+ "specify the number of requests"+ , Option+ ['m']+ ["use-connected-socket"]+ (NoArg (\o -> o{optUnconSock = False}))+ "use connected sockets instead of unconnected sockets"+ ] showUsageAndExit :: String -> IO a showUsageAndExit msg = do@@ -147,85 +193,98 @@ clientOpts :: [String] -> IO (Options, [String]) clientOpts argv = case getOpt Permute options argv of- (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)- (_,_,errs) -> showUsageAndExit $ concat errs+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs main :: IO () main = do args <- getArgs (opts@Options{..}, ips) <- clientOpts args- (addr,port,path) <- case ips of- [a,b] -> return (a,b,"/")- [a,b,c] -> return (a,b,c)- _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"+ let ipslen = length ips+ when (ipslen /= 2 && ipslen /= 3) $+ showUsageAndExit "cannot recognize <addr> and <port>\n" cmvar <- newEmptyMVar- let ccalpn ver- | optPerformance /= 0 = return $ Just ["perf"]- | otherwise = let (h3X, hqX) = makeProtos ver- protos | optHQ = [hqX,h3X]- | otherwise = [h3X,hqX]- in return $ Just protos+ let path+ | ipslen == 3 = ips !! 2+ | otherwise = "/"+ addr = head ips+ port = head $ tail ips+ ccalpn ver+ | optPerformance /= 0 = return $ Just ["perf"]+ | otherwise =+ let (h3X, hqX) = makeProtos ver+ protos+ | optHQ = [hqX, h3X]+ | otherwise = [h3X, hqX]+ in return $ Just protos gvers vers- | optVerNego = GreasingVersion : vers- | otherwise = vers+ | optVerNego = GreasingVersion : vers+ | otherwise = vers setTPQuantum params- | optQuantum = let bs = BS.replicate 1200 0- in params { grease = Just bs }- | otherwise = params+ | optQuantum =+ let bs = BS.replicate 1200 0+ in params{grease = Just bs}+ | otherwise = params cc0 = defaultClientConfig- cc = cc0 {- ccServerName = addr- , ccPortName = port- , ccALPN = ccalpn- , ccValidate = optValidate- , ccPacketSize = optPacketSize- , ccDebugLog = optDebugLog- , ccVersions = gvers $ ccVersions cc0- , ccParameters = setTPQuantum $ ccParameters cc0- , ccKeyLog = getLogger optKeyLogFile- , ccGroups = getGroups (ccGroups cc0) optGroups- , ccQLog = optQLogDir- , ccHooks = defaultHooks {- onCloseCompleted = putMVar cmvar ()- }- , ccAutoMigration = optUnconSock- }- debug | optDebugLog = putStrLn- | otherwise = \_ -> return ()- showContent | optShow = C8.putStrLn- | otherwise = \_ -> return ()- aux = Aux {- auxPath = path- , auxAuthority = addr- , auxDebug = debug- , auxShow = showContent- , auxCheckClose = do- mx <- timeout 1000000 $ takeMVar cmvar- case mx of- Nothing -> return False- _ -> return True- }+ cc =+ cc0+ { ccServerName = addr+ , ccPortName = port+ , ccALPN = ccalpn+ , ccValidate = optValidate+ , ccPacketSize = optPacketSize+ , ccDebugLog = optDebugLog+ , ccVersions = gvers $ ccVersions cc0+ , ccParameters = setTPQuantum $ ccParameters cc0+ , ccKeyLog = getLogger optKeyLogFile+ , ccGroups = getGroups (ccGroups cc0) optGroups+ , ccQLog = optQLogDir+ , ccHooks =+ defaultHooks+ { onCloseCompleted = putMVar cmvar ()+ }+ , ccAutoMigration = optUnconSock+ }+ debug+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ showContent+ | optShow = C8.putStrLn+ | otherwise = \_ -> return ()+ aux =+ Aux+ { auxPath = path+ , auxAuthority = addr+ , auxDebug = debug+ , auxShow = showContent+ , auxCheckClose = do+ mx <- T.timeout 1000000 $ takeMVar cmvar+ case mx of+ Nothing -> return False+ _ -> return True+ } runClient cc opts aux runClient :: ClientConfig -> Options -> Aux -> IO () runClient cc opts@Options{..} aux@Aux{..} = do auxDebug "------------------------"- (info1,info2,res,mig,client') <- run cc $ \conn -> do+ (info1, info2, res, mig, client') <- run cc $ \conn -> do i1 <- getConnectionInfo conn let client = case alpn i1 of- Just proto | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs- _ -> clientH3 optNumOfReqs+ Just proto | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs+ _ -> clientH3 optNumOfReqs m <- case optMigration of- Nothing -> return False- Just mtyp -> do- x <- controlConnection conn mtyp- auxDebug $ "Migration by " ++ show mtyp- return x+ Nothing -> return False+ Just mtyp -> do+ x <- controlConnection conn mtyp+ auxDebug $ "Migration by " ++ show mtyp+ return x t1 <- getUnixTime- if optInteractive then do- console aux client conn- else do- client aux conn+ if optInteractive+ then do+ console aux client conn+ else do+ client aux conn stats <- getConnectionStats conn print stats t2 <- getUnixTime@@ -233,84 +292,99 @@ r <- getResumptionInfo conn printThroughput t1 t2 stats return (i1, i2, r, m, client)- if optVerNego then do- putStrLn "Result: (V) version negotiation ... OK"- exitSuccess- else if optQuantum then do- putStrLn "Result: (Q) quantum ... OK"- exitSuccess- else if optResumption then do- if isResumptionPossible res then do- info3 <- runClient2 cc opts aux res client'- if handshakeMode info3 == PreSharedKey then do- putStrLn "Result: (R) TLS resumption ... OK"+ if+ | optVerNego -> do+ putStrLn "Result: (V) version negotiation ... OK"+ exitSuccess+ | optQuantum -> do+ putStrLn "Result: (Q) quantum ... OK"+ exitSuccess+ | optResumption -> do+ if isResumptionPossible res+ then do+ info3 <- runClient2 cc opts aux res client'+ if handshakeMode info3 == PreSharedKey+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ | opt0RTT -> do+ if is0RTTPossible res+ then do+ info3 <- runClient2 cc opts aux res client'+ if handshakeMode info3 == RTT0+ then do+ putStrLn "Result: (Z) 0-RTT ... OK"+ exitSuccess+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ | optRetry -> do+ if retry info1+ then do+ putStrLn "Result: (S) retry ... OK"+ exitSuccess+ else do+ putStrLn "Result: (S) retry ... NG"+ exitFailure+ | otherwise -> case optMigration of+ Just ChangeServerCID -> do+ let changed = remoteCID info1 /= remoteCID info2+ if mig && remoteCID info1 /= remoteCID info2+ then do+ putStrLn "Result: (M) change server CID ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig, changed)+ exitFailure+ Just ChangeClientCID -> do+ let changed = localCID info1 /= localCID info2+ if mig && changed+ then do+ putStrLn "Result: (N) change client CID ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig, changed)+ exitFailure+ Just NATRebinding -> do+ putStrLn "Result: (B) NAT rebinding ... OK" exitSuccess- else do- putStrLn "Result: (R) TLS resumption ... NG"- exitFailure- else do- putStrLn "Result: (R) TLS resumption ... NG"- exitFailure- else if opt0RTT then do- if is0RTTPossible res then do- info3 <- runClient2 cc opts aux res client'- if handshakeMode info3 == RTT0 then do- putStrLn "Result: (Z) 0-RTT ... OK"+ Just ActiveMigration -> do+ let changed = remoteCID info1 /= remoteCID info2+ if mig && changed+ then do+ putStrLn "Result: (A) address mobility ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig, changed)+ exitFailure+ Nothing -> do+ putStrLn "Result: (H) handshake ... OK"+ putStrLn "Result: (D) stream data ... OK"+ closeCompleted <- auxCheckClose+ when closeCompleted $ putStrLn "Result: (C) close completed ... OK"+ case alpn info1 of+ Nothing -> return ()+ Just alpn ->+ when ("h3" `BS.isPrefixOf` alpn) $+ putStrLn "Result: (3) H3 transaction ... OK" exitSuccess- else do- putStrLn "Result: (Z) 0-RTT ... NG"- exitFailure- else do- putStrLn "Result: (Z) 0-RTT ... NG"- exitFailure- else if optRetry then do- if retry info1 then do- putStrLn "Result: (S) retry ... OK"- exitSuccess- else do- putStrLn "Result: (S) retry ... NG"- exitFailure- else case optMigration of- Just ChangeServerCID -> do- let changed = remoteCID info1 /= remoteCID info2- if mig && remoteCID info1 /= remoteCID info2 then do- putStrLn "Result: (M) change server CID ... OK"- exitSuccess- else do- putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig,changed)- exitFailure- Just ChangeClientCID -> do- let changed = localCID info1 /= localCID info2- if mig && changed then do- putStrLn "Result: (N) change client CID ... OK"- exitSuccess- else do- putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig,changed)- exitFailure- Just NATRebinding -> do- putStrLn "Result: (B) NAT rebinding ... OK"- exitSuccess- Just ActiveMigration -> do- let changed = remoteCID info1 /= remoteCID info2- if mig && changed then do- putStrLn "Result: (A) address mobility ... OK"- exitSuccess- else do- putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig,changed)- exitFailure- Nothing -> do- putStrLn "Result: (H) handshake ... OK"- putStrLn "Result: (D) stream data ... OK"- closeCompleted <- auxCheckClose- when closeCompleted $ putStrLn "Result: (C) close completed ... OK"- case alpn info1 of- Nothing -> return ()- Just alpn -> when ("h3" `BS.isPrefixOf` alpn) $- putStrLn "Result: (3) H3 transaction ... OK"- exitSuccess -runClient2 :: ClientConfig -> Options -> Aux -> ResumptionInfo -> Cli- -> IO ConnectionInfo+runClient2+ :: ClientConfig+ -> Options+ -> Aux+ -> ResumptionInfo+ -> Cli+ -> IO ConnectionInfo runClient2 cc Options{..} aux@Aux{..} res client = do threadDelay 100000 auxDebug "<<<< next connection >>>>"@@ -319,20 +393,31 @@ void $ client aux conn getConnectionInfo conn where- cc' = cc {- ccResumption = res- , ccUse0RTT = opt0RTT && is0RTTPossible res- }+ cc' =+ cc+ { ccResumption = res+ , ccUse0RTT = opt0RTT && is0RTTPossible res+ } printThroughput :: UnixTime -> UnixTime -> ConnectionStats -> IO () printThroughput t1 t2 ConnectionStats{..} =- printf "Throughput %.2f Mbps (%d bytes in %d msecs)\n" bytesPerSeconds rxBytes millisecs+ printf+ "Throughput %.2f Mbps (%d bytes in %d msecs)\n"+ bytesPerSeconds+ rxBytes+ millisecs where UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1 millisecs :: Int millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000 bytesPerSeconds :: Double- bytesPerSeconds = fromIntegral rxBytes * (1000 :: Double) * 8 / fromIntegral millisecs / 1024 / 1024+ bytesPerSeconds =+ fromIntegral rxBytes+ * (1000 :: Double)+ * 8+ / fromIntegral millisecs+ / 1024+ / 1024 console :: Aux -> (Aux -> Connection -> IO ()) -> Connection -> IO () console aux client conn = do@@ -342,25 +427,25 @@ putStrLn "p -- ping" putStrLn "n -- NAT rebinding" loop- where- loop = do- hSetBuffering stdout NoBuffering- putStr "> "- hSetBuffering stdout LineBuffering- l <- getLine- case l of- "q" -> putStrLn "bye"- "g" -> do- putStrLn $ "GET " ++ auxPath aux- _ <- forkIO $ client aux conn- loop- "p" -> do- putStrLn "Ping"- sendFrames conn RTT1Level [Ping]- loop- "n" -> do- controlConnection conn NATRebinding >>= print- loop- _ -> do- putStrLn "No such command"- loop+ where+ loop = do+ hSetBuffering stdout NoBuffering+ putStr "> "+ hSetBuffering stdout LineBuffering+ l <- getLine+ case l of+ "q" -> putStrLn "bye"+ "g" -> do+ putStrLn $ "GET " ++ auxPath aux+ _ <- forkIO $ client aux conn+ loop+ "p" -> do+ putStrLn "Ping"+ sendFrames conn RTT1Level [Ping]+ loop+ "n" -> do+ controlConnection conn NATRebinding >>= print+ loop+ _ -> do+ putStrLn "No such command"+ loop
util/qif.hs view
@@ -9,7 +9,7 @@ import Control.Monad import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P-import Data.ByteString (ByteString, ByteString)+import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Conduit.Attoparsec@@ -19,7 +19,7 @@ import Network.QPACK -data Block = Block Int ByteString deriving Show+data Block = Block Int ByteString deriving (Show) ---------------------------------------------------------------- @@ -27,26 +27,32 @@ main = do args <- getArgs case args of- [size,efile] -> dump (read size) efile- [size,efile,qfile] -> test (read size) efile qfile- _ -> putStrLn "qif size <encode-file> [<qif-file>]"+ [size, efile] -> dump (read size) efile+ [size, efile, qfile] -> test (read size) efile qfile+ _ -> putStrLn "qif size <encode-file> [<qif-file>]" ---------------------------------------------------------------- dump :: Int -> FilePath -> IO () dump size efile = do- (dec, insthdr) <- newQDecoderS defaultQDecoderConfig { dcDynamicTableSize = size } True- runConduitRes (sourceFile efile .| conduitParser block .| mapM_C (liftIO . dumpSwitch dec insthdr))+ (dec, insthdr) <-+ newQDecoderS defaultQDecoderConfig{dcDynamicTableSize = size} True+ runConduitRes+ ( sourceFile efile+ .| conduitParser block+ .| mapM_C (liftIO . dumpSwitch dec insthdr)+ ) -dumpSwitch :: (ByteString -> IO HeaderList)- -> EncoderInstructionHandlerS- -> (a, Block)- -> IO ()+dumpSwitch+ :: (ByteString -> IO HeaderList)+ -> EncoderInstructionHandlerS+ -> (a, Block)+ -> IO () dumpSwitch dec insthdr (_, Block n bs)- | n == 0 = do+ | n == 0 = do putStrLn "---- Stream 0" insthdr bs- | otherwise = do+ | otherwise = do putStrLn $ "---- Stream " ++ show n _ <- dec bs return ()@@ -55,9 +61,10 @@ test :: Int -> FilePath -> FilePath -> IO () test size efile qfile = do- (dec, insthdr') <- newQDecoderS defaultQDecoderConfig { dcDynamicTableSize = size } False+ (dec, insthdr') <-+ newQDecoderS defaultQDecoderConfig{dcDynamicTableSize = size} False q <- newTQueueIO- let recv = atomically $ readTQueue q+ let recv = atomically $ readTQueue q send x = atomically $ writeTQueue q x insthdr bs = do emp <- atomically $ isEmptyTQueue q@@ -67,40 +74,45 @@ mvar <- newEmptyMVar withFile qfile ReadMode $ \h -> do tid <- forkIO $ decode dec h recv mvar- runConduitRes (sourceFile efile .| conduitParser block .| mapM_C (liftIO . testSwitch send insthdr))+ runConduitRes+ ( sourceFile efile+ .| conduitParser block+ .| mapM_C (liftIO . testSwitch send insthdr)+ ) takeMVar mvar killThread tid -testSwitch :: (Block -> IO ())- -> EncoderInstructionHandlerS- -> (a, Block)- -> IO ()+testSwitch+ :: (Block -> IO ())+ -> EncoderInstructionHandlerS+ -> (a, Block)+ -> IO () testSwitch send insthdr (_, blk@(Block n bs))- | n == 0 = insthdr bs- | otherwise = send blk+ | n == 0 = insthdr bs+ | otherwise = send blk decode :: QDecoderS -> Handle -> IO Block -> MVar () -> IO () decode dec h recv mvar = loop where loop = do hdr' <- fromCaseSensitive <$> headerlist h- if hdr' == [] then- putMVar mvar ()- else do- Block n bs <- recv- hdr <- dec bs- if hdr == hdr' then- loop- else do- putStrLn $ "---- Stream " ++ show n- mapM_ print hdr- putStrLn "----"- mapM_ print hdr'- putStrLn "----"- putMVar mvar ()+ if hdr' == []+ then putMVar mvar ()+ else do+ Block n bs <- recv+ hdr <- dec bs+ if hdr == hdr'+ then loop+ else do+ putStrLn $ "---- Stream " ++ show n+ mapM_ print hdr+ putStrLn "----"+ mapM_ print hdr'+ putStrLn "----"+ putMVar mvar () fromCaseSensitive :: HeaderList -> HeaderList-fromCaseSensitive = map (\(k,v) -> (foldedCase $ mk k,v))+fromCaseSensitive = map (\(k, v) -> (foldedCase $ mk k, v)) ---------------------------------------------------------------- @@ -124,19 +136,19 @@ loop b = do ml <- line h case ml of- Nothing -> return $ b []- Just l- | l == "" -> return $ b []- | otherwise -> do- let (k,v0) = BS8.break (== '\t') l- v = BS8.drop 1 v0- loop (b . ((k,v) :))+ Nothing -> return $ b []+ Just l+ | l == "" -> return $ b []+ | otherwise -> do+ let (k, v0) = BS8.break (== '\t') l+ v = BS8.drop 1 v0+ loop (b . ((k, v) :)) line :: Handle -> IO (Maybe ByteString) line h = do el <- E.try $ BS8.hGetLine h case el of- Left (_ :: E.IOException) -> return Nothing- Right l- | BS8.take 1 l == "#" -> line h- | otherwise -> return $ Just l+ Left (_ :: E.IOException) -> return Nothing+ Right l+ | BS8.take 1 l == "#" -> line h+ | otherwise -> return $ Just l
util/server.hs view
@@ -11,7 +11,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.List as L-import Network.TLS (credentialLoadX509, Credentials(..))+import Network.TLS (Credentials (..), credentialLoadX509) import qualified Network.TLS.SessionManager as SM import System.Console.GetOpt import System.Environment (getArgs)@@ -24,51 +24,67 @@ import Network.QUIC.Server import ServerX -data Options = Options {- optDebugLogDir :: Maybe FilePath- , optQLogDir :: Maybe FilePath- , optKeyLogFile :: Maybe FilePath- , optGroups :: Maybe String- , optCertFile :: FilePath- , optKeyFile :: FilePath- , optRetry :: Bool- } deriving Show+data Options = Options+ { optDebugLogDir :: Maybe FilePath+ , optQLogDir :: Maybe FilePath+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: Maybe String+ , optCertFile :: FilePath+ , optKeyFile :: FilePath+ , optRetry :: Bool+ }+ deriving (Show) defaultOptions :: Options-defaultOptions = Options {- optDebugLogDir = Nothing- , optQLogDir = Nothing- , optKeyLogFile = Nothing- , optGroups = Nothing- , optCertFile = "servercert.pem"- , optKeyFile = "serverkey.pem"- , optRetry = False- }+defaultOptions =+ Options+ { optDebugLogDir = Nothing+ , optQLogDir = Nothing+ , optKeyLogFile = Nothing+ , optGroups = Nothing+ , optCertFile = "servercert.pem"+ , optKeyFile = "serverkey.pem"+ , optRetry = False+ } options :: [OptDescr (Options -> Options)]-options = [- Option ['d'] ["debug-log-dir"]- (ReqArg (\dir o -> o { optDebugLogDir = Just dir }) "<dir>")- "directory to store a debug file"- , Option ['q'] ["qlog-dir"]- (ReqArg (\dir o -> o { optQLogDir = Just dir }) "<dir>")- "directory to store qlog"- , Option ['l'] ["key-log-file"]- (ReqArg (\file o -> o { optKeyLogFile = Just file }) "<file>")- "a file to store negotiated secrets"- , Option ['g'] ["groups"]- (ReqArg (\gs o -> o { optGroups = Just gs }) "<groups>")- "groups for key exchange"- , Option ['c'] ["cert"]- (ReqArg (\fl o -> o { optCertFile = fl }) "<file>")- "certificate file"- , Option ['k'] ["key"]- (ReqArg (\fl o -> o { optKeyFile = fl }) "<file>")- "key file"- , Option ['S'] ["retry"]- (NoArg (\o -> o { optRetry = True }))- "require stateless retry"- ]+options =+ [ Option+ ['d']+ ["debug-log-dir"]+ (ReqArg (\dir o -> o{optDebugLogDir = Just dir}) "<dir>")+ "directory to store a debug file"+ , Option+ ['q']+ ["qlog-dir"]+ (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")+ "directory to store qlog"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")+ "groups for key exchange"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")+ "key file"+ , Option+ ['S']+ ["retry"]+ (NoArg (\o -> o{optRetry = True}))+ "require stateless retry"+ ] usage :: String usage = "Usage: server [OPTION] addr [addrs] port"@@ -82,19 +98,19 @@ serverOpts :: [String] -> IO (Options, [String]) serverOpts argv = case getOpt Permute options argv of- (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)- (_,_,errs) -> showUsageAndExit $ concat errs+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs chooseALPN :: Version -> [ByteString] -> IO ByteString chooseALPN _ protos- | "perf" `elem` protos = return "perf"+ | "perf" `elem` protos = return "perf" chooseALPN ver protos = return $ case mh3idx of- Nothing -> case mhqidx of- Nothing -> ""- Just _ -> hqX- Just h3idx -> case mhqidx of- Nothing -> h3X- Just hqidx -> if h3idx < hqidx then h3X else hqX+ Nothing -> case mhqidx of+ Nothing -> ""+ Just _ -> hqX+ Just h3idx -> case mhqidx of+ Nothing -> h3X+ Just hqidx -> if h3idx < hqidx then h3X else hqX where (h3X, hqX) = makeProtos ver mh3idx = h3X `L.elemIndex` protos@@ -110,23 +126,24 @@ addrs = read <$> init ips aps = (,port) <$> addrs smgr <- SM.newSessionManager SM.defaultConfig- Right cred@(!_cc,!_priv) <- credentialLoadX509 optCertFile optKeyFile+ Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile let sc0 = defaultServerConfig- sc = sc0 {- scAddresses = aps- , scALPN = Just chooseALPN- , scRequireRetry = optRetry- , scSessionManager = smgr- , scUse0RTT = True- , scDebugLog = optDebugLogDir- , scKeyLog = getLogger optKeyLogFile- , scGroups = getGroups (scGroups sc0) optGroups- , scQLog = optQLogDir- , scCredentials = Credentials [cred]- }+ sc =+ sc0+ { scAddresses = aps+ , scALPN = Just chooseALPN+ , scRequireRetry = optRetry+ , scSessionManager = smgr+ , scUse0RTT = True+ , scDebugLog = optDebugLogDir+ , scKeyLog = getLogger optKeyLogFile+ , scGroups = getGroups (scGroups sc0) optGroups+ , scQLog = optQLogDir+ , scCredentials = Credentials [cred]+ } run sc $ \conn -> do info <- getConnectionInfo conn let server = case alpn info of- Just proto | "hq" `BS.isPrefixOf` proto -> serverHQ- _ -> serverH3+ Just proto | "hq" `BS.isPrefixOf` proto -> serverHQ+ _ -> serverH3 server conn