diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,30 @@ +# ChangeLog for http-semantics + +## 0.2.0 + +* Introduce `responseStreamingIface` + [#9](https://github.com/kazu-yamamoto/http-semantics/pull/9) + +## 0.1.2 + +* Avoid buffer overflow in fillBufBuilderOne + [#4](https://github.com/kazu-yamamoto/http-semantics/pull/4) + +## 0.1.1 + +* Avoid buffer overflow in runStreamingBuilder + [#3](https://github.com/kazu-yamamoto/http-semantics/pull/3) + +## 0.1.0 + +* Make it possible to guarantee that final DATA frame is marked end-of-stream. + [#2](https://github.com/kazu-yamamoto/http-semantics/pull/2) + +## 0.0.1 + +* Defining getResponseBodyChunk'. + [#1](https://github.com/kazu-yamamoto/http-semantics/pull/1) + +## 0.0.0 + +* The first release. diff --git a/Network/HTTP/Semantics/Client.hs b/Network/HTTP/Semantics/Client.hs --- a/Network/HTTP/Semantics/Client.hs +++ b/Network/HTTP/Semantics/Client.hs @@ -120,7 +120,7 @@ -> RequestHeaders -> (OutBodyIface -> IO ()) -> Request -requestStreamingIface m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingUnmask strmbdy) defaultTrailersMaker +requestStreamingIface m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingIface strmbdy) defaultTrailersMaker where hdr' = addHeaders m p hdr diff --git a/Network/HTTP/Semantics/FillBuf.hs b/Network/HTTP/Semantics/FillBuf.hs --- a/Network/HTTP/Semantics/FillBuf.hs +++ b/Network/HTTP/Semantics/FillBuf.hs @@ -9,6 +9,7 @@ DynaNext, BytesFilled, StreamingChunk (..), + IsEndOfStream (..), CleanupStream, fillBuilderBodyGetNext, fillFileBodyGetNext, @@ -21,6 +22,7 @@ import qualified Data.ByteString.Builder.Extra as B import Data.ByteString.Internal import Data.Int (Int64) +import Data.Maybe import Foreign.Ptr (plusPtr) import Network.ByteOrder import Network.HTTP.Semantics.Client @@ -42,22 +44,28 @@ data StreamingChunk = -- | Indicate that the stream is finished - StreamingFinished CleanupStream + StreamingFinished (Maybe CleanupStream) | -- | Flush the stream -- -- This will cause the write buffer to be written to the network socket, -- without waiting for more data. StreamingFlush | -- | Construct a DATA frame, optionally terminating the stream - -- - -- The optional 'CleanupStream' argument can be used to ensure that the - -- final DATA frame in the stream is marked as end-of-stream, as opposed - -- to using a separate, /empty/, data frame with this flag set. - StreamingBuilder Builder (Maybe CleanupStream) + StreamingBuilder Builder IsEndOfStream -- | Action to run prior to terminating the stream type CleanupStream = IO () +data IsEndOfStream = + -- | The stream is not yet terminated + NotEndOfStream + + -- | The stream is terminated + -- + -- In addition to indicating that the stream is terminated, we can also + -- specify an optional `Cleanup` handler to be run. + | EndOfStream (Maybe CleanupStream) + ---------------------------------------------------------------- fillBuilderBodyGetNext :: Builder -> DynaNext @@ -122,14 +130,14 @@ runStreamingChunk :: StreamingChunk -> NextWithTotal -> NextWithTotal runStreamingChunk chunk next = case chunk of - StreamingFinished dec -> finished dec + StreamingFinished mdec -> finished mdec StreamingFlush -> flush - StreamingBuilder builder Nothing -> runStreamingBuilder builder next - StreamingBuilder builder (Just dec) -> runStreamingBuilder builder (finished dec) + StreamingBuilder builder NotEndOfStream -> runStreamingBuilder builder next + StreamingBuilder builder (EndOfStream mdec) -> runStreamingBuilder builder (finished mdec) where - finished :: CleanupStream -> NextWithTotal - finished dec = \total _buf _room -> do - dec + finished :: Maybe CleanupStream -> NextWithTotal + finished mdec = \total _buf _room -> do + fromMaybe (return ()) mdec return $ Next total True Nothing flush :: NextWithTotal diff --git a/Network/HTTP/Semantics/Server.hs b/Network/HTTP/Semantics/Server.hs --- a/Network/HTTP/Semantics/Server.hs +++ b/Network/HTTP/Semantics/Server.hs @@ -33,6 +33,10 @@ responseStreaming, responseBuilder, + -- ** Generalized streaming interface + OutBodyIface(..), + responseStreamingIface, + -- ** Accessing response responseBodySize, @@ -165,6 +169,16 @@ -> ((Builder -> IO ()) -> IO () -> IO ()) -> Response responseStreaming st hdr strmbdy = Response $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker + where + hdr' = setStatus st hdr + +-- | Generalization of 'responseStreaming'. +responseStreamingIface + :: H.Status + -> H.ResponseHeaders + -> (OutBodyIface -> IO ()) + -> Response +responseStreamingIface st hdr strmbdy = Response $ OutObj hdr' (OutBodyStreamingIface strmbdy) defaultTrailersMaker where hdr' = setStatus st hdr diff --git a/Network/HTTP/Semantics/Types.hs b/Network/HTTP/Semantics/Types.hs --- a/Network/HTTP/Semantics/Types.hs +++ b/Network/HTTP/Semantics/Types.hs @@ -54,26 +54,23 @@ = OutBodyNone | -- | Streaming body takes a write action and a flush action. OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ()) - | -- | Like 'OutBodyStreaming', but with a callback to unmask expections - -- - -- This is used in the client: we spawn the new thread for the request body - -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask' - -- with a callback to unmask them again (typically after installing an exception - -- handler). - -- - -- We do /NOT/ support this in the server, as here the scope of the thread - -- that is spawned for the server is the entire handler, not just the response - -- streaming body. - -- - -- TODO: The analogous change for the server-side would be to provide a similar - -- @unmask@ callback as the first argument in the 'Server' type alias. - OutBodyStreamingUnmask (OutBodyIface -> IO ()) + | -- | Generalization of 'OutBodyStreaming'. + OutBodyStreamingIface (OutBodyIface -> IO ()) | OutBodyBuilder Builder | OutBodyFile FileSpec data OutBodyIface = OutBodyIface { outBodyUnmask :: (forall x. IO x -> IO x) -- ^ Unmask exceptions in the thread spawned for the request body + -- + -- This is used in the client: we spawn the new thread for the request body + -- with exceptions masked, and provide the body of 'OutBodyStreamingIface' + -- with a callback to unmask them again (typically after installing an + -- exception handler). + -- + -- Unmasking in the server is a no-op, as here the scope of the thread that + -- is spawned for the server is the entire handler, not just the response + -- streaming body. , outBodyPush :: Builder -> IO () -- ^ Push a new chunk , outBodyPushFinal :: Builder -> IO () diff --git a/http-semantics.cabal b/http-semantics.cabal --- a/http-semantics.cabal +++ b/http-semantics.cabal @@ -1,17 +1,16 @@ -cabal-version: >=1.10 -name: http-semantics -version: 0.1.2 -license: BSD3 -license-file: LICENSE -maintainer: Kazu Yamamoto -author: Kazu Yamamoto -homepage: https://github.com/kazu-yamamoto/http-semantics -synopsis: HTTP senmatics libarry -description: Version-independent common parts of HTTP - - -category: Network -build-type: Simple +cabal-version: 3.0 +name: http-semantics +version: 0.2.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: Kazu Yamamoto +author: Kazu Yamamoto +homepage: https://github.com/kazu-yamamoto/http-semantics +synopsis: HTTP senmatics libarry +description: Version-independent common parts of HTTP +category: Network +build-type: Simple +extra-doc-files: ChangeLog.md source-repository head type: git @@ -49,4 +48,3 @@ network-byte-order, time-manager, utf8-string -