http3 0.0.16 → 0.0.17

raw patch · 3 files changed

+91/−21 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Network/HTTP3/Server.hs +85/−20
• http3.cabal +2/−1

@@ -1,5 +1,9 @@ # Revision history for http3 +## 0.0.17++* Providing ServerIO API+ ## 0.0.16  * Using quic v0.2

@@ -13,14 +13,21 @@     Hooks (..),     defaultHooks,     module Network.HTTP.Semantics.Server,++    -- * Internal+    runIO,+    ServerIO (..), ) where  import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM import Data.IORef import Network.HTTP.Semantics import Network.HTTP.Semantics.Server import Network.HTTP.Semantics.Server.Internal-import Network.QUIC (Connection, Stream)+import Network.HTTP2.Server.Internal (ServerIO (..))+import Network.QUIC (Connection, ConnectionInfo (..), Stream, getConnectionInfo) import qualified Network.QUIC as QUIC import qualified System.TimeManager as T import qualified UnliftIO.Exception as E@@ -40,16 +47,42 @@ run conn conf server = E.bracket open close $ \ctx -> do     tid <- forkIO $ setupUnidirectional conn conf     addThreadId ctx tid-    readerServer ctx server+    readerServer ctx $ \strm ->+        void $+            forkFinally+                (processRequest ctx server strm)+                (\_ -> closeStream strm)   where     open = do         ref <- newIORef IInit         newContext conn conf (controlStream conn ref)     close = clearContext -readerServer :: Context -> Server -> IO ()-readerServer ctx server = loop+runIO :: Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()+runIO conn conf action = E.bracket open close $ \ctx -> do+    tid <- forkIO $ setupUnidirectional conn conf+    info <- getConnectionInfo conn+    addThreadId ctx tid+    reqq <- newTQueueIO+    let sio =+            ServerIO+                { sioMySockAddr = localSockAddr info+                , sioPeerSockAddr = remoteSockAddr info+                , sioReadRequest = atomically $ readTQueue reqq+                , sioWriteResponse = sendResponseIO ctx+                }+        put strmreq = atomically $ writeTQueue reqq strmreq+    io <- action sio+    concurrently_ io (readerServer ctx $ processRequestIO ctx put)   where+    open = do+        ref <- newIORef IInit+        newContext conn conf (controlStream conn ref)+    close = clearContext++readerServer :: Context -> (Stream -> IO ()) -> IO ()+readerServer ctx action = loop+  where     loop = do         accept ctx >>= process         loop@@ -57,8 +90,7 @@         | QUIC.isClientInitiatedUnidirectional sid = do             tid <- forkIO $ unidirectional ctx strm             addThreadId ctx tid-        | QUIC.isClientInitiatedBidirectional sid =-            void $ forkFinally (processRequest ctx server strm) (\_ -> closeStream strm)+        | QUIC.isClientInitiatedBidirectional sid = action strm         | QUIC.isServerInitiatedUnidirectional sid = return () -- error         | otherwise = return ()       where@@ -71,20 +103,8 @@     mvt <- recvHeader ctx src     case mvt of         Nothing -> QUIC.resetStream strm H3MessageError-        Just ht@(_, vt) -> do-            let mMethod = getFieldValue tokenMethod vt-                mScheme = getFieldValue tokenScheme vt-                mAuthority = getFieldValue tokenAuthority vt-                mPath = getFieldValue 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+        Just ht -> do+            req <- mkRequest ctx strm src ht             let aux = Aux th (getMySockAddr ctx) (getPeerSockAddr ctx)             server req aux $ sendResponse ctx strm th   where@@ -93,9 +113,54 @@             abort ctx QpackDecompressionFailed         | otherwise = QUIC.resetStream strm H3MessageError +processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO ()+processRequestIO ctx put strm = E.handleAny reset $ do+    src <- newSource strm+    mvt <- recvHeader ctx src+    case mvt of+        Nothing -> QUIC.resetStream strm H3MessageError+        Just ht -> do+            req <- mkRequest ctx strm src ht+            put (strm, req)+  where+    reset se+        | Just (_ :: DecodeError) <- E.fromException se =+            abort ctx QpackDecompressionFailed+        | otherwise = QUIC.resetStream strm H3MessageError++mkRequest+    :: Context+    -> Stream+    -> Source+    -> (TokenHeaderList, ValueTable)+    -> IO Request+mkRequest ctx strm src ht@(_, vt) = do+    let mMethod = getFieldValue tokenMethod vt+        mScheme = getFieldValue tokenScheme vt+        mAuthority = getFieldValue tokenAuthority vt+        mPath = getFieldValue 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+    return req+ sendResponse     :: Context -> Stream -> T.Handle -> Response -> [PushPromise] -> IO () sendResponse ctx strm th (Response outobj) _pp = do     sendHeader ctx strm th $ outObjHeaders outobj     sendBody ctx strm th outobj     QUIC.shutdownStream strm++sendResponseIO+    :: Context -> Stream -> Response -> IO ()+sendResponseIO ctx strm (Response outobj) = do+    th <- registerThread ctx -- fixme+    sendHeader ctx strm th $ outObjHeaders outobj+    sendBody ctx strm th outobj+    QUIC.closeStream strm

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               http3-version:            0.0.16+version:            0.0.17 license:            BSD-3-Clause license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -77,6 +77,7 @@     ghc-options:        -Wall     build-depends:         base >=4.9 && <5,+        async,         array,         bytestring,         case-insensitive,