http2 3.0.2 → 3.0.3
raw patch · 8 files changed
+117/−26 lines, 8 filesdep ~aesonPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson
API changes (from Hackage documentation)
Files
- ChangeLog.md +11/−0
- Network/HTTP2/Arch/Sender.hs +6/−0
- Network/HTTP2/Arch/Status.hs +1/−1
- Network/HTTP2/Client/Run.hs +9/−8
- http2.cabal +9/−7
- test-frame/JSON.hs +1/−1
- test-hpack/JSON.hs +4/−3
- test/HTTP2/ServerSpec.hs +76/−6
ChangeLog.md view
@@ -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
Network/HTTP2/Arch/Sender.hs view
@@ -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
Network/HTTP2/Arch/Status.hs view
@@ -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
Network/HTTP2/Client/Run.hs view
@@ -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
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 3.0.2+Version: 3.0.3 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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
test-frame/JSON.hs view
@@ -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
test-hpack/JSON.hs view
@@ -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
test/HTTP2/ServerSpec.hs view
@@ -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