diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,33 @@ # ChangeLog for http-semantics +## 0.4.2 + +* `defaultReadNWith` is `defaultReadN` with an `STM` action beside each + receive. When it fires the read answers with the empty string, which is + what `ReadN` already means by end of input, so a reader blocked in it can + be given up on without closing the socket under it or throwing into it -- + neither of which works everywhere. + +## 0.4.1 + +* Add `auxSendInformational` to the server `Aux` for sending 1xx informational + responses (e.g. 103 Early Hints) ahead of the final response. + +## 0.4.0 + +* This version is idential to v0.3.1 which includes breaking changes + and thus is deprecated. + +## 0.3.1 + +* Adding defaultAux and auxSendPing for client. +* Adding defaultAux for server. + +## 0.3.0 + +* Breaking change: fillFileBodyGetNext takes Sentinel instead of + IO () to close files on time. + ## 0.2.1 * Add outBodyCancel to OutBodyIface 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 @@ -17,7 +17,7 @@ requestBuilder, -- ** Generalized streaming interface - OutBodyIface(..), + OutBodyIface (..), requestStreamingIface, -- ** Trailers maker @@ -39,7 +39,9 @@ -- * Aux Aux, + defaultAux, auxPossibleClientStreams, + auxSendPing, -- * Types Scheme, diff --git a/Network/HTTP/Semantics/Client/Internal.hs b/Network/HTTP/Semantics/Client/Internal.hs --- a/Network/HTTP/Semantics/Client/Internal.hs +++ b/Network/HTTP/Semantics/Client/Internal.hs @@ -2,6 +2,7 @@ Request (..), Response (..), Aux (..), + defaultAux, ) where import Network.HTTP.Semantics.Types (InpObj (..), OutObj (..)) @@ -16,4 +17,13 @@ data Aux = Aux { auxPossibleClientStreams :: IO Int -- ^ How many streams can be created without blocking. + , auxSendPing :: IO () + -- ^ Sending a ping. } + +defaultAux :: Aux +defaultAux = + Aux + { auxPossibleClientStreams = return 0 + , auxSendPing = return () + } 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Semantics.FillBuf ( @@ -25,7 +22,7 @@ import Data.Int (Int64) import Data.Maybe import Foreign.Ptr (plusPtr) -import Network.ByteOrder +import Network.ByteOrder hiding (start) import Network.HTTP.Semantics.Client ---------------------------------------------------------------- @@ -35,7 +32,7 @@ -- In @http2@ this will be used to construct a single HTTP2 @DATA@ frame -- (see discussion of the maximum number of bytes, below). type DynaNext = - Buffer + Buffer -- ^ Write buffer -> Int -- ^ Maximum number of bytes we are allowed to write @@ -76,15 +73,14 @@ -- | 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) +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) ---------------------------------------------------------------- @@ -94,11 +90,11 @@ return $ nextForBuilder len signal fillFileBodyGetNext - :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext -fillFileBodyGetNext pread start bytecount refresh buf room = do + :: PositionRead -> FileOffset -> ByteCount -> Sentinel -> DynaNext +fillFileBodyGetNext pread start bytecount sentinel buf room = do len <- pread start (mini room bytecount) buf let len' = fromIntegral len - return $ nextForFile len' pread (start + len) (bytecount - len) refresh + nextForFile len' pread (start + len) (bytecount - len) sentinel fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext fillStreamBodyGetNext takeQ = loop 0 @@ -116,10 +112,10 @@ fillBufBuilderOne minReq writer buf0 room = do if room >= minReq then do - (len, signal) <- writer buf0 room - return $ nextForBuilder len signal + (len, signal) <- writer buf0 room + return $ nextForBuilder len signal else do - return $ Next 0 True (Just $ fillBufBuilderOne minReq writer) + return $ Next 0 True (Just $ fillBufBuilderOne minReq writer) fillBufBuilderTwo :: ByteString -> B.BufferWriter -> DynaNext fillBufBuilderTwo bs writer buf0 room @@ -202,10 +198,10 @@ let enoughRoom = maybe True (room >=) mMinReq if enoughRoom then do - writeResult <- writer buf room - ranWriter writeResult total buf room + writeResult <- writer buf room + ranWriter writeResult total buf room else do - return $ Next total True (Just $ goMore mMinReq writer 0) + return $ Next total True (Just $ goMore mMinReq writer 0) goChunk :: ByteString -> B.BufferWriter -> NextWithTotal goChunk bs writer = \total buf room -> @@ -221,19 +217,25 @@ ---------------------------------------------------------------- -fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext -fillBufFile pread start bytes refresh buf room = do +fillBufFile :: PositionRead -> FileOffset -> ByteCount -> Sentinel -> DynaNext +fillBufFile pread start bytes sentinel buf room = do len <- pread start (mini room bytes) buf - refresh + case sentinel of + Refresher refresh -> refresh + _ -> return () let len' = fromIntegral len - return $ nextForFile len' pread (start + len) (bytes - len) refresh + nextForFile len' pread (start + len) (bytes - len) sentinel nextForFile - :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next -nextForFile 0 _ _ _ _ = Next 0 True Nothing -- let's flush -nextForFile len _ _ 0 _ = Next len False Nothing + :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> Sentinel -> IO Next +nextForFile 0 _ _ _ _ = return $ Next 0 True Nothing -- let's flush +nextForFile len _ _ 0 sentinel = do + case sentinel of + Closer close -> close + _ -> return () + return $ Next len False Nothing nextForFile len pread start bytes refresh = - Next len False $ Just $ fillBufFile pread start bytes refresh + return $ Next len False $ Just $ fillBufFile pread start bytes refresh {-# INLINE mini #-} mini :: Int -> Int64 -> Int64 diff --git a/Network/HTTP/Semantics/ReadN.hs b/Network/HTTP/Semantics/ReadN.hs --- a/Network/HTTP/Semantics/ReadN.hs +++ b/Network/HTTP/Semantics/ReadN.hs @@ -2,9 +2,11 @@ -- * Reading n bytes ReadN, defaultReadN, + defaultReadNWith, ) where +import Control.Concurrent.STM import qualified Data.ByteString as B import Data.IORef import Network.Socket @@ -19,13 +21,25 @@ -- (It is probably quite rare anyway to want concurrent reads from the /same/ -- network socket.) defaultReadN :: Socket -> IORef (Maybe B.ByteString) -> ReadN -defaultReadN _ _ 0 = return B.empty -defaultReadN s ref n = do +defaultReadN s ref = defaultReadNWith s ref retry + +-- | 'defaultReadN' which the caller can give up on. The 'STM' action is +-- waited for beside each receive; when it fires, the read answers with the +-- empty string, which is how 'ReadN' already says that there is nothing more. +-- +-- /NOTE/: the bytes read so far are discarded, so this ends a connection +-- rather than pausing one. The caller cannot tell a give-up from the peer +-- hanging up; whoever fired the 'STM' action knows which it was. +-- +-- @since 0.4.2 +defaultReadNWith :: Socket -> IORef (Maybe B.ByteString) -> STM a -> ReadN +defaultReadNWith _ _ _ 0 = return B.empty +defaultReadNWith s ref giveUp n = do mbs <- readIORef ref writeIORef ref Nothing case mbs of Nothing -> do - bs <- N.recv s n + bs <- recv1 n if B.null bs then return B.empty else @@ -40,9 +54,10 @@ return bs0 | otherwise -> loop bs where + recv1 n' = either (const B.empty) id <$> N.recvWith s n' giveUp loop bs = do let n' = n - B.length bs - bs1 <- N.recv s n' + bs1 <- recv1 n' if B.null bs1 then return B.empty else do 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.HTTP.Semantics.Server ( -- * HTTP server Server, @@ -20,9 +18,11 @@ -- * Aux Aux, + defaultAux, auxTimeHandle, auxMySockAddr, auxPeerSockAddr, + auxSendInformational, -- * Response Response, @@ -34,7 +34,7 @@ responseBuilder, -- ** Generalized streaming interface - OutBodyIface(..), + OutBodyIface (..), responseStreamingIface, -- ** Accessing response @@ -66,12 +66,25 @@ import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef import qualified Network.HTTP.Types as H +import Network.Socket +import qualified System.TimeManager as T import Network.HTTP.Semantics import Network.HTTP.Semantics.File import Network.HTTP.Semantics.ReadN import Network.HTTP.Semantics.Server.Internal import Network.HTTP.Semantics.Status + +---------------------------------------------------------------- + +defaultAux :: Aux +defaultAux = + Aux + { auxTimeHandle = T.emptyHandle + , auxMySockAddr = SockAddrInet 0 0 + , auxPeerSockAddr = SockAddrInet 0 0 + , auxSendInformational = \_ _ -> return () + } ---------------------------------------------------------------- diff --git a/Network/HTTP/Semantics/Server/Internal.hs b/Network/HTTP/Semantics/Server/Internal.hs --- a/Network/HTTP/Semantics/Server/Internal.hs +++ b/Network/HTTP/Semantics/Server/Internal.hs @@ -4,6 +4,7 @@ Aux (..), ) where +import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import qualified System.TimeManager as T @@ -23,4 +24,10 @@ -- ^ Local socket address copied from 'Config'. , auxPeerSockAddr :: SockAddr -- ^ Remove socket address copied from 'Config'. + , auxSendInformational :: H.Status -> H.ResponseHeaders -> IO () + -- ^ Send an informational (1xx) response, e.g. 103 Early Hints, on this + -- request's stream before the final response. May be called multiple + -- times. A no-op in 'defaultAux'. + -- + -- @since 0.4.1 } 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 @@ -61,7 +61,7 @@ | OutBodyFile FileSpec data OutBodyIface = OutBodyIface - { outBodyUnmask :: (forall x. IO x -> IO x) + { 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 @@ -86,16 +86,20 @@ -- Using this function instead of 'outBodyPush' can be used to guarantee -- that the final HTTP2 DATA frame is marked end-of-stream; with -- 'outBodyPush' it may happen that an additional empty DATA frame is used - -- for this purpose. Additionally, after calling this function, - -- 'outBodyCancel' will be a no-op. + -- for this purpose. , outBodyCancel :: Maybe SomeException -> IO () -- ^ Cancel the stream -- - -- Sends a @RST_STREAM@ to the peer. If cancelling as the result of an - -- exception, a 'Just' should be provided which specifies the exception - -- which will be stored locally as the reason for cancelling the stream; in - -- this case, the error code sent with the @RST_STREAM@ will be - -- @INTERNAL_ERROR@ (see + -- Cancelling a streams sends a @RST_STREAM@ to the network peer, which + -- tells them that they should stop sending us messages. As such, it may + -- still be necessary to call 'outBodyCancel' after 'outBodyPushFinal', + -- which merely tells the peer that /we/ will no longer send /them/ any more + -- messages. + -- + -- If cancelling as the result of an exception, a 'Just' should be provided + -- which specifies the exception, which will be stored locally as the reason + -- for cancelling the stream; in this case, the error code sent with the + -- @RST_STREAM@ will be @INTERNAL_ERROR@ (see -- ). If 'Nothing' -- is given, the error code will be @CANCEL@. -- diff --git a/http-semantics.cabal b/http-semantics.cabal --- a/http-semantics.cabal +++ b/http-semantics.cabal @@ -1,12 +1,12 @@ cabal-version: 3.0 name: http-semantics -version: 0.2.1 +version: 0.4.2 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 +synopsis: HTTP semantics library description: Version-independent common parts of HTTP category: Network build-type: Simple @@ -44,7 +44,8 @@ bytestring >=0.10, case-insensitive, http-types >=0.12 && <0.13, - network, + network >=3.2.10, network-byte-order, - time-manager, + stm, + time-manager >= 0.2.4, utf8-string