diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +## 3.0.3 + +* Return correct status messages in HTTP2 client + (#31)[https://github.com/kazu-yamamoto/http2/pull/31] +* Follow changes in Aeson 2 + (#32)[https://github.com/kazu-yamamoto/http2/pull/32] +* Make sure connection preface is always sent first + (#33)[https://github.com/kazu-yamamoto/http2/pull/33] +* Avoid empty data + (#34)[https://github.com/kazu-yamamoto/http2/pull/34] + ## 3.0.2 * Skip inserting entries that do not fit in the encoding table diff --git a/Network/HTTP2/Arch/Sender.hs b/Network/HTTP2/Arch/Sender.hs --- a/Network/HTTP2/Arch/Sender.hs +++ b/Network/HTTP2/Arch/Sender.hs @@ -272,6 +272,12 @@ kvlen <- headerContinue streamNumber ths True off0 sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen + fillDataHeaderEnqueueNext _ + off 0 (Just next) tlrmkr _ out = do + let out' = out { outputType = ONext next tlrmkr } + enqueueOutput outputQ out' + return off + fillDataHeaderEnqueueNext Stream{streamWindow,streamNumber} off datPayloadLen (Just next) tlrmkr _ out = do let buf = confWriteBuffer `plusPtr` off diff --git a/Network/HTTP2/Arch/Status.hs b/Network/HTTP2/Arch/Status.hs --- a/Network/HTTP2/Arch/Status.hs +++ b/Network/HTTP2/Arch/Status.hs @@ -41,4 +41,4 @@ toStatus :: ByteString -> Maybe H.Status toStatus bs = case C8.readInt bs of Nothing -> Nothing - Just (code,_) -> Just $ H.mkStatus code "fixme" + Just (code,_) -> Just $ toEnum code diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -3,6 +3,7 @@ module Network.HTTP2.Client.Run where +import Control.Concurrent.Async import Control.Concurrent import qualified Control.Exception as E import Data.IORef (writeIORef) @@ -24,15 +25,15 @@ clientInfo <- newClientInfo scheme authority cacheLimit ctx <- newContext clientInfo mgr <- start confTimeoutManager - tid0 <- forkIO $ frameReceiver ctx confReadN - -- fixme: if frameSender is terminated but the main thread is alive, - -- what will happen? - tid1 <- forkIO $ frameSender ctx conf mgr + let runBackgroundThreads = do + race_ + (frameReceiver ctx confReadN) + (frameSender ctx conf mgr) + E.throwIO (ConnectionError ProtocolError "connection terminated") exchangeSettings conf ctx - client (sendRequest ctx scheme authority) `E.finally` do - stop mgr - killThread tid0 - killThread tid1 + fmap (either id id) $ + race runBackgroundThreads (client (sendRequest ctx scheme authority)) + `E.finally` stop mgr sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a sendRequest ctx@Context{..} scheme auth (Request req) processResponse = do diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 3.0.2 +Version: 3.0.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -119,6 +119,7 @@ Network.HTTP2.Server.Worker Build-Depends: base >= 4.9 && < 5 , array + , async , bytestring >= 0.10 , case-insensitive , containers >= 0.5 @@ -169,6 +170,7 @@ , hspec >= 1.3 , http-types , http2 + , network , network-run >= 0.1.0 , typed-process Default-Extensions: Strict StrictData @@ -206,7 +208,7 @@ HPACKSpec JSON Build-Depends: base >= 4.9 && < 5 - , aeson + , aeson >= 2 , base16-bytestring >= 1.0 , bytestring , directory @@ -230,7 +232,7 @@ JSON Build-Depends: base >= 4.9 && < 5 , Glob >= 0.9 - , aeson + , aeson >= 2 , aeson-pretty , base16-bytestring >= 1.0 , bytestring @@ -293,7 +295,7 @@ Other-Modules: HPACKEncode JSON Build-Depends: base >= 4.9 && < 5 - , aeson + , aeson >= 2 , aeson-pretty , array , base16-bytestring >= 1.0 @@ -320,7 +322,7 @@ Other-Modules: HPACKDecode JSON Build-Depends: base >= 4.9 && < 5 - , aeson + , aeson >= 2 , array , base16-bytestring >= 1.0 , bytestring @@ -345,7 +347,7 @@ Main-Is: hpack-stat.hs Other-Modules: JSON Build-Depends: base >= 4.9 && < 5 - , aeson + , aeson >= 2 , aeson-pretty , array , bytestring @@ -373,7 +375,7 @@ Other-Modules: Case JSON Build-Depends: base >= 4.9 && < 5 - , aeson + , aeson >= 2 , aeson-pretty , base16-bytestring >= 1.0 , bytestring diff --git a/test-frame/JSON.hs b/test-frame/JSON.hs --- a/test-frame/JSON.hs +++ b/test-frame/JSON.hs @@ -14,7 +14,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -import Data.HashMap.Strict (union) +import Data.Aeson.KeyMap (union) import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T diff --git a/test-hpack/JSON.hs b/test-hpack/JSON.hs --- a/test-hpack/JSON.hs +++ b/test-hpack/JSON.hs @@ -14,7 +14,8 @@ import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 -import qualified Data.HashMap.Strict as H +import qualified Data.Aeson.KeyMap as H +import qualified Data.Aeson.Key as Key import Data.Text (Text) import qualified Data.Text as T import Data.Vector ((!)) @@ -83,13 +84,13 @@ parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old where toKey = toValue - parseJSON (Object o) = pure (textToByteString k, toValue v) -- new + parseJSON (Object o) = pure (textToByteString (Key.toText k), toValue v) -- new where (k,v) = head $ H.toList o parseJSON _ = mzero instance {-# OVERLAPPING #-} ToJSON Header where - toJSON (k,v) = object [ byteStringToText k .= byteStringToText v ] + toJSON (k,v) = object [ Key.fromText (byteStringToText k) .= byteStringToText v ] textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -10,16 +10,20 @@ import Crypto.Hash (Context, SHA1) -- cryptonite import qualified Crypto.Hash as CH import qualified Data.ByteString as B -import Data.ByteString.Builder (byteString) +import Data.ByteString.Builder (byteString, Builder) import Data.ByteString.Char8 import qualified Data.ByteString.Char8 as C8 +import Data.IORef import Network.HTTP.Types import Network.Run.TCP +import Network.Socket +import Network.Socket.ByteString import Test.Hspec import Network.HPACK import qualified Network.HTTP2.Client as C import Network.HTTP2.Server +import Network.HTTP2.Frame port :: String port = "8080" @@ -33,8 +37,19 @@ it "handles normal cases" $ E.bracket (forkIO runServer) killThread $ \_ -> do threadDelay 10000 - runClient + (runClient allocSimpleConfig) + it "should always send the connection preface first" $ do + prefaceVar <- newEmptyMVar + E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do + threadDelay 10000 + E.catch (runClient allocSlowPrefaceConfig) ignoreHTTP2Error + preface <- takeMVar prefaceVar + preface `shouldBe` connectionPreface + +ignoreHTTP2Error :: HTTP2Error -> IO () +ignoreHTTP2Error _ = pure () + runServer :: IO () runServer = runTCPServer (Just host) port runHTTP2Server where @@ -42,10 +57,32 @@ freeSimpleConfig (`run` server) +runFakeServer :: MVar ByteString -> IO () +runFakeServer prefaceVar = do + runTCPServer (Just host) port $ \s -> do + ref <- newIORef Nothing + + -- send settings + sendAll s $ "\x00\x00\x12\x04\x00\x00\x00\x00\x00" + `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00" + `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff" + + -- receive preface + value <- defaultReadN s ref (B.length connectionPreface) + putMVar prefaceVar value + + -- send goaway frame + sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01" + + -- wait for a few ms to make sure the client has a chance to close the + -- socket on its end + threadDelay 10000 + server :: Server server req _aux sendResponse = case requestMethod req of Just "GET" -> case requestPath req of Just "/" -> sendResponse responseHello [] + Just "/stream" -> sendResponse responseInfinite [] Just "/push" -> do let pp = pushPromise "/push-pp" responsePP 0 sendResponse responseHello [pp] @@ -68,6 +105,15 @@ ,("x-push", "True")] body = byteString "Push\n" +responseInfinite :: Response +responseInfinite = responseStreaming ok200 header body + where + header = [("Content-Type", "text/plain")] + body :: (Builder -> IO ()) -> IO () -> IO () + body write flush = do + let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n) + go (0 :: Int) + response404 :: Response response404 = responseNoBody notFound404 [] @@ -100,22 +146,36 @@ where !ctx' = CH.hashUpdate ctx bs -runClient :: IO () -runClient = runTCPClient host port $ runHTTP2Client +runClient :: (Socket -> BufferSize -> IO Config) -> IO () +runClient allocConfig = + runTCPClient host port $ runHTTP2Client where authority = C8.pack host cliconf = C.ClientConfig "http" authority 20 - runHTTP2Client s = E.bracket (allocSimpleConfig s 4096) + runHTTP2Client s = E.bracket (allocConfig s 4096) freeSimpleConfig (\conf -> C.run cliconf conf client) client sendRequest = mapConcurrently_ ($ sendRequest) clients - clients = [client0,client1,client2,client3,client4] + clients = [client0,client1,client2,client3,client4,client5] +-- delay sending preface to be able to test if it is always sent first +allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config +allocSlowPrefaceConfig s size = do + config <- allocSimpleConfig s size + pure config { confSendAll = slowPrefaceSend (confSendAll config) } + where + slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO () + slowPrefaceSend orig chunk = do + when (C8.pack "PRI" `isPrefixOf` chunk) $ do + threadDelay 10000 + orig chunk + client0 :: C.Client () client0 sendRequest = do let req = C.requestNoBody methodGet "/" [] sendRequest req $ \rsp -> do C.responseStatus rsp `shouldBe` Just ok200 + fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK" client1 :: C.Client () client1 sendRequest = do @@ -151,6 +211,16 @@ let req1 = C.requestNoBody methodGet "/push-pp" [] sendRequest req1 $ \rsp -> do C.responseStatus rsp `shouldBe` Just ok200 + +client5 :: C.Client () +client5 sendRequest = do + let req0 = C.requestNoBody methodGet "/stream" [] + sendRequest req0 $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + let go n | n > 0 = do _ <- C.getResponseBodyChunk rsp + go (pred n) + | otherwise = pure () + go (100 :: Int) firstTrailerValue :: HeaderTable -> HeaderValue firstTrailerValue = snd . Prelude.head . fst