http-semantics-0.3.0/0000755000000000000000000000000007346545000012646 5ustar0000000000000000http-semantics-0.3.0/ChangeLog.md0000644000000000000000000000203607346545000015020 0ustar0000000000000000# ChangeLog for http-semantics ## 0.3.0 * Breaking change: fillFileBodyGetNext takes Sentinel instead of IO () to close files on time. ## 0.2.1 * Add outBodyCancel to OutBodyIface [#11](https://github.com/kazu-yamamoto/http-semantics/pull/11) * Documentation improvement. [#10](https://github.com/kazu-yamamoto/http-semantics/pull/10) [#11](https://github.com/kazu-yamamoto/http-semantics/pull/11) ## 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. http-semantics-0.3.0/LICENSE0000644000000000000000000000276507346545000013665 0ustar0000000000000000Copyright (c) 2024, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-semantics-0.3.0/Network/HTTP/0000755000000000000000000000000007346545000015056 5ustar0000000000000000http-semantics-0.3.0/Network/HTTP/Semantics.hs0000644000000000000000000000077707346545000017353 0ustar0000000000000000-- | Library for HTTP Semantics ([RFC9110](https://www.rfc-editor.org/rfc/rfc9110.html)), version-independent common parts. For low-level headers, 'Token' is used. For upper-level headers, 'Network.HTTP.Types.HeaderName' should be used. module Network.HTTP.Semantics ( module Network.HTTP.Semantics.Types, module Network.HTTP.Semantics.Header, module Network.HTTP.Semantics.Token, ) where import Network.HTTP.Semantics.Header import Network.HTTP.Semantics.Token import Network.HTTP.Semantics.Types http-semantics-0.3.0/Network/HTTP/Semantics/0000755000000000000000000000000007346545000017004 5ustar0000000000000000http-semantics-0.3.0/Network/HTTP/Semantics/Client.hs0000644000000000000000000001135707346545000020565 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Network.HTTP.Semantics.Client ( -- * HTTP client Client, SendRequest, -- * Request Request, -- * Creating request requestNoBody, requestFile, requestStreaming, requestStreamingUnmask, requestBuilder, -- ** Generalized streaming interface OutBodyIface (..), requestStreamingIface, -- ** Trailers maker TrailersMaker, NextTrailersMaker (..), defaultTrailersMaker, setRequestTrailersMaker, -- * Response Response, -- ** Accessing response responseStatus, responseHeaders, responseBodySize, getResponseBodyChunk, getResponseBodyChunk', getResponseTrailers, -- * Aux Aux, auxPossibleClientStreams, -- * Types Scheme, Authority, Method, Path, FileSpec (..), FileOffset, ByteCount, module Network.HTTP.Semantics.ReadN, module Network.HTTP.Semantics.File, ) where import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Data.IORef (readIORef) import Network.HTTP.Types (Method, RequestHeaders, Status) import Network.HTTP.Semantics import Network.HTTP.Semantics.Client.Internal import Network.HTTP.Semantics.File import Network.HTTP.Semantics.ReadN import Network.HTTP.Semantics.Status ---------------------------------------------------------------- -- | Send a request and receive its response. type SendRequest = forall r. Request -> (Response -> IO r) -> IO r -- | Client type. type Client a = SendRequest -> Aux -> IO a ---------------------------------------------------------------- -- | Creating request without body. requestNoBody :: Method -> Path -> RequestHeaders -> Request requestNoBody m p hdr = Request $ OutObj hdr' OutBodyNone defaultTrailersMaker where hdr' = addHeaders m p hdr -- | Creating request with file. requestFile :: Method -> Path -> RequestHeaders -> FileSpec -> Request requestFile m p hdr fileSpec = Request $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker where hdr' = addHeaders m p hdr -- | Creating request with builder. requestBuilder :: Method -> Path -> RequestHeaders -> Builder -> Request requestBuilder m p hdr builder = Request $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker where hdr' = addHeaders m p hdr -- | Creating request with streaming. requestStreaming :: Method -> Path -> RequestHeaders -> ((Builder -> IO ()) -> IO () -> IO ()) -> Request requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker where hdr' = addHeaders m p hdr -- | Like 'requestStreaming', but run the action with exceptions masked requestStreamingUnmask :: Method -> Path -> RequestHeaders -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) -> Request requestStreamingUnmask m p hdr strmbdy = requestStreamingIface m p hdr $ \iface -> strmbdy (outBodyUnmask iface) (outBodyPush iface) (outBodyFlush iface) -- | Generalized version of 'requestStreaming', requestStreamingIface :: Method -> Path -> RequestHeaders -> (OutBodyIface -> IO ()) -> Request requestStreamingIface m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingIface strmbdy) defaultTrailersMaker where hdr' = addHeaders m p hdr addHeaders :: Method -> Path -> RequestHeaders -> RequestHeaders addHeaders m p hdr = (":method", m) : (":path", p) : hdr -- | Setting 'TrailersMaker' to 'Response'. setRequestTrailersMaker :: Request -> TrailersMaker -> Request setRequestTrailersMaker (Request req) tm = Request req{outObjTrailers = tm} ---------------------------------------------------------------- -- | Getting the status of a response. responseStatus :: Response -> Maybe Status responseStatus (Response rsp) = getStatus $ inpObjHeaders rsp -- | Getting the headers from a response. responseHeaders :: Response -> TokenHeaderTable responseHeaders (Response rsp) = inpObjHeaders rsp -- | Getting the body size from a response. responseBodySize :: Response -> Maybe Int responseBodySize (Response rsp) = inpObjBodySize rsp -- | Reading a chunk of the response body. -- An empty 'ByteString' returned when finished. getResponseBodyChunk :: Response -> IO ByteString getResponseBodyChunk = fmap fst . getResponseBodyChunk' -- | Generalization of 'getResponseBodyChunk' which also returns if the 'ByteString' is the final one getResponseBodyChunk' :: Response -> IO (ByteString, Bool) getResponseBodyChunk' (Response rsp) = inpObjBody rsp -- | Reading response trailers. -- This function must be called after 'getResponseBodyChunk' -- returns an empty. getResponseTrailers :: Response -> IO (Maybe TokenHeaderTable) getResponseTrailers (Response rsp) = readIORef (inpObjTrailers rsp) http-semantics-0.3.0/Network/HTTP/Semantics/Client/0000755000000000000000000000000007346545000020222 5ustar0000000000000000http-semantics-0.3.0/Network/HTTP/Semantics/Client/Internal.hs0000644000000000000000000000073507346545000022337 0ustar0000000000000000module Network.HTTP.Semantics.Client.Internal ( Request (..), Response (..), Aux (..), ) where import Network.HTTP.Semantics.Types (InpObj (..), OutObj (..)) -- | Request from client. newtype Request = Request OutObj deriving (Show) -- | Response from server. newtype Response = Response InpObj deriving (Show) -- | Additional information. data Aux = Aux { auxPossibleClientStreams :: IO Int -- ^ How many streams can be created without blocking. } http-semantics-0.3.0/Network/HTTP/Semantics/File.hs0000644000000000000000000000222407346545000020217 0ustar0000000000000000module Network.HTTP.Semantics.File ( -- * Position read PositionRead, PositionReadMaker, Sentinel (..), defaultPositionReadMaker, ) where import System.IO import Network.ByteOrder import Network.HTTP.Semantics -- | Position read for files. type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount -- | Making a position read and its closer. type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel) --- | Manipulating a file resource. data Sentinel = -- | Closing a file resource. Its refresher is automatiaclly generated by -- the internal timer. Closer (IO ()) | -- | Refreshing a file resource while reading. -- Closing the file must be done by its own timer or something. Refresher (IO ()) -- | Position read based on 'Handle'. defaultPositionReadMaker :: PositionReadMaker defaultPositionReadMaker file = do hdl <- openBinaryFile file ReadMode return (pread hdl, Closer $ hClose hdl) where pread :: Handle -> PositionRead pread hdl off bytes buf = do hSeek hdl AbsoluteSeek $ fromIntegral off fromIntegral <$> hGetBufSome hdl buf (fromIntegral bytes) http-semantics-0.3.0/Network/HTTP/Semantics/FillBuf.hs0000644000000000000000000002162207346545000020666 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Semantics.FillBuf ( -- * Filling a buffer Next (..), DynaNext, BytesFilled, StreamingChunk (..), IsEndOfStream (..), CleanupStream, fillBuilderBodyGetNext, fillFileBodyGetNext, fillStreamBodyGetNext, ) where import Control.Exception (SomeException) import Control.Monad import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) 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 ---------------------------------------------------------------- -- | Write part of a streaming response to the write buffer -- -- 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 -- ^ Write buffer -> Int -- ^ Maximum number of bytes we are allowed to write -- -- In @http2@, this maximum will be set to the space left in the write -- buffer. Implicitly this also means that this maximum cannot exceed the -- maximum size of a HTTP2 frame, since in @http2@ the size of the write -- buffer is also used to set @SETTINGS_MAX_FRAME_SIZE@ (see -- @confBufferSize@). -> IO Next -- ^ Information on the data written, and on how to continue if not all data -- was written type BytesFilled = Int data Next = Next BytesFilled -- payload length Bool -- require flushing (Maybe DynaNext) | CancelNext (Maybe SomeException) ---------------------------------------------------------------- data StreamingChunk = -- | Indicate that the stream is finished StreamingFinished (Maybe CleanupStream) | -- | Indicate that the stream is cancelled StreamingCancelled (Maybe SomeException) | -- | 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 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 fillBuilderBodyGetNext bb buf room = do (len, signal) <- B.runBuilder bb buf room return $ nextForBuilder len signal fillFileBodyGetNext :: PositionRead -> FileOffset -> ByteCount -> Sentinel -> DynaNext fillFileBodyGetNext pread start bytecount sentinel buf room = do len <- pread start (mini room bytecount) buf let len' = fromIntegral len nextForFile len' pread (start + len) (bytecount - len) sentinel fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext fillStreamBodyGetNext takeQ = loop 0 where loop :: NextWithTotal loop total buf room = do mChunk <- takeQ case mChunk of Just chunk -> runStreamingChunk chunk loop total buf room Nothing -> return $ Next total False (Just $ loop 0) ---------------------------------------------------------------- fillBufBuilderOne :: Int -> B.BufferWriter -> DynaNext fillBufBuilderOne minReq writer buf0 room = do if room >= minReq then do (len, signal) <- writer buf0 room return $ nextForBuilder len signal else do return $ Next 0 True (Just $ fillBufBuilderOne minReq writer) fillBufBuilderTwo :: ByteString -> B.BufferWriter -> DynaNext fillBufBuilderTwo bs writer buf0 room | BS.length bs <= room = do buf1 <- copy buf0 bs let len1 = BS.length bs (len2, signal) <- writer buf1 (room - len1) return $ nextForBuilder (len1 + len2) signal | otherwise = do let (bs1, bs2) = BS.splitAt room bs void $ copy buf0 bs1 return $ nextForBuilder room (B.Chunk bs2 writer) nextForBuilder :: BytesFilled -> B.Next -> Next nextForBuilder len B.Done = Next len True Nothing -- let's flush nextForBuilder len (B.More minReq writer) = Next len False $ Just (fillBufBuilderOne minReq writer) nextForBuilder len (B.Chunk bs writer) = Next len False $ Just (fillBufBuilderTwo bs writer) ---------------------------------------------------------------- -- | Like 'DynaNext', but with additional argument indicating total bytes written -- -- Since @http2@ uses @DynaNext@ to construct a /single/ @DATA@ frame, the -- \"total number of bytes written\" refers to the current size of the payload -- of that @DATA@ frame. type NextWithTotal = Int -> DynaNext -- | Run the chunk, then continue as specified, unless streaming is finished runStreamingChunk :: StreamingChunk -> NextWithTotal -> NextWithTotal runStreamingChunk chunk next = case chunk of StreamingFinished mdec -> finished mdec StreamingCancelled mErr -> cancel mErr StreamingFlush -> flush StreamingBuilder builder NotEndOfStream -> runStreamingBuilder builder next StreamingBuilder builder (EndOfStream mdec) -> runStreamingBuilder builder (finished mdec) where finished :: Maybe CleanupStream -> NextWithTotal finished mdec = \total _buf _room -> do fromMaybe (return ()) mdec return $ Next total True Nothing flush :: NextWithTotal flush = \total _buf _room -> do return $ Next total True (Just $ next 0) -- Cancel streaming -- -- The @_total@ number of bytes written refers to the @DATA@ frame currently -- under construction, but not yet sent (see discussion at 'DynaNext' and -- 'NextWithTotal'). Moreover, the documentation of 'outBodyCancel' -- explicitly states that such a partially constructed frame, if one exists, -- will be discarded on cancellation. We can therefore simply ignore -- @_total@ here. cancel :: Maybe SomeException -> NextWithTotal cancel mErr = \_total _buf _room -> pure $ CancelNext mErr -- | Run 'Builder' until completion, then continue as specified runStreamingBuilder :: Builder -> NextWithTotal -> NextWithTotal runStreamingBuilder builder next = \total buf room -> do writeResult <- B.runBuilder builder buf room ranWriter writeResult total buf room where ranWriter :: (Int, B.Next) -> NextWithTotal ranWriter (len, signal) = \total buf room -> do let total' = total + len case signal of B.Done -> next total' (buf `plusPtr` len) (room - len) B.More minReq writer -> return $ Next total' False (Just $ goMore (Just minReq) writer 0) B.Chunk bs writer -> return $ Next total' False (Just $ goChunk bs writer 0) goMore :: Maybe Int -> B.BufferWriter -> NextWithTotal goMore mMinReq writer = \total buf room -> do let enoughRoom = maybe True (room >=) mMinReq if enoughRoom then do writeResult <- writer buf room ranWriter writeResult total buf room else do return $ Next total True (Just $ goMore mMinReq writer 0) goChunk :: ByteString -> B.BufferWriter -> NextWithTotal goChunk bs writer = \total buf room -> if BS.length bs <= room then do buf' <- copy buf bs let len = BS.length bs goMore Nothing writer (total + len) buf' (room - len) else do let (bs1, bs2) = BS.splitAt room bs void $ copy buf bs1 return $ Next (total + room) False (Just $ goChunk bs2 writer 0) ---------------------------------------------------------------- fillBufFile :: PositionRead -> FileOffset -> ByteCount -> Sentinel -> DynaNext fillBufFile pread start bytes sentinel buf room = do len <- pread start (mini room bytes) buf case sentinel of Refresher refresh -> refresh _ -> return () let len' = fromIntegral len nextForFile len' pread (start + len) (bytes - len) sentinel nextForFile :: 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 = return $ Next len False $ Just $ fillBufFile pread start bytes refresh {-# INLINE mini #-} mini :: Int -> Int64 -> Int64 mini i n | fromIntegral i < n = fromIntegral i | otherwise = n http-semantics-0.3.0/Network/HTTP/Semantics/Header.hs0000644000000000000000000000313107346545000020526 0ustar0000000000000000module Network.HTTP.Semantics.Header ( -- * Low-level headers. FieldName, FieldValue, TokenHeader, TokenHeaderList, TokenHeaderTable, -- * Value table ValueTable, getFieldValue, -- * Deprecated HeaderTable, HeaderValue, getHeaderValue, ) where import Data.Array (Array) import Data.Array.Base (unsafeAt) import Network.HTTP.Semantics.Token import Data.ByteString (ByteString) -- | Field name. Internal usage only. type FieldName = ByteString -- | Field value. type FieldValue = ByteString {-# DEPRECATED HeaderValue "use FieldValue instead" #-} -- | Header value. type HeaderValue = ByteString -- | An array to get 'FieldValue' quickly. -- 'getHeaderValue' should be used. -- Internally, the key is 'tokenIx'. type ValueTable = Array Int (Maybe FieldValue) {-# DEPRECATED HeaderTable "use TokenHeaderTable instead" #-} -- | A pair of token list and value table. type HeaderTable = (TokenHeaderList, ValueTable) -- | A pair of token list and value table. type TokenHeaderTable = (TokenHeaderList, ValueTable) -- | TokenBased header. type TokenHeader = (Token, FieldValue) -- | TokenBased header list. type TokenHeaderList = [TokenHeader] {-# DEPRECATED getHeaderValue "use geFieldValue instead" #-} -- | Accessing 'FieldValue' with 'Token'. {-# INLINE getHeaderValue #-} getHeaderValue :: Token -> ValueTable -> Maybe FieldValue getHeaderValue t tbl = tbl `unsafeAt` tokenIx t -- | Accessing 'FieldValue' with 'Token'. {-# INLINE getFieldValue #-} getFieldValue :: Token -> ValueTable -> Maybe FieldValue getFieldValue t tbl = tbl `unsafeAt` tokenIx t http-semantics-0.3.0/Network/HTTP/Semantics/IO.hs0000644000000000000000000000054607346545000017654 0ustar0000000000000000module Network.HTTP.Semantics.IO ( module Network.HTTP.Semantics.ReadN, module Network.HTTP.Semantics.File, module Network.HTTP.Semantics.FillBuf, module Network.HTTP.Semantics.Trailer, ) where import Network.HTTP.Semantics.File import Network.HTTP.Semantics.FillBuf import Network.HTTP.Semantics.ReadN import Network.HTTP.Semantics.Trailer http-semantics-0.3.0/Network/HTTP/Semantics/ReadN.hs0000644000000000000000000000273107346545000020334 0ustar0000000000000000module Network.HTTP.Semantics.ReadN ( -- * Reading n bytes ReadN, defaultReadN, ) where import qualified Data.ByteString as B import Data.IORef import Network.Socket import qualified Network.Socket.ByteString as N -- | Reading n bytes. type ReadN = Int -> IO B.ByteString -- | Naive implementation for readN. -- -- /NOTE/: This function is intended to be used by a single thread only. -- (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 mbs <- readIORef ref writeIORef ref Nothing case mbs of Nothing -> do bs <- N.recv s n if B.null bs then return B.empty else if B.length bs == n then return bs else loop bs Just bs | B.length bs == n -> return bs | B.length bs > n -> do let (bs0, bs1) = B.splitAt n bs writeIORef ref (Just bs1) return bs0 | otherwise -> loop bs where loop bs = do let n' = n - B.length bs bs1 <- N.recv s n' if B.null bs1 then return B.empty else do let bs2 = bs `B.append` bs1 if B.length bs2 == n then return bs2 else loop bs2 http-semantics-0.3.0/Network/HTTP/Semantics/Server.hs0000644000000000000000000001417307346545000020614 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Semantics.Server ( -- * HTTP server Server, -- * Request Request, -- ** Accessing request requestMethod, requestPath, requestAuthority, requestScheme, requestHeaders, requestBodySize, getRequestBodyChunk, getRequestBodyChunk', getRequestTrailers, -- * Aux Aux, auxTimeHandle, auxMySockAddr, auxPeerSockAddr, -- * Response Response, -- ** Creating response responseNoBody, responseFile, responseStreaming, responseBuilder, -- ** Generalized streaming interface OutBodyIface (..), responseStreamingIface, -- ** Accessing response responseBodySize, -- ** Trailers maker TrailersMaker, NextTrailersMaker (..), defaultTrailersMaker, setResponseTrailersMaker, -- * Push promise PushPromise (..), pushPromise, -- * Types Path, Authority, Scheme, FileSpec (..), FileOffset, ByteCount, module Network.HTTP.Semantics.ReadN, module Network.HTTP.Semantics.File, ) where import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef import qualified Network.HTTP.Types as H 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 ---------------------------------------------------------------- -- | Server type. Server takes a HTTP request, should -- generate a HTTP response and push promises, then -- should give them to the sending function. -- The sending function would throw exceptions so that -- they can be logged. -- -- The sending function must only be called once. type Server = Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO () -- | HTTP/2 push promise or sever push. -- Pseudo REQUEST headers in push promise is automatically generated. -- Then, a server push is sent according to 'promiseResponse'. data PushPromise = PushPromise { promiseRequestPath :: ByteString -- ^ Accessor for a URL path in a push promise (a virtual request from a server). -- E.g. \"\/style\/default.css\". , promiseResponse :: Response -- ^ Accessor for response actually pushed from a server. } ---------------------------------------------------------------- -- | Getting the method from a request. requestMethod :: Request -> Maybe H.Method requestMethod (Request req) = getFieldValue tokenMethod vt where (_, vt) = inpObjHeaders req -- | Getting the path from a request. requestPath :: Request -> Maybe Path requestPath (Request req) = getFieldValue tokenPath vt where (_, vt) = inpObjHeaders req -- | Getting the authority from a request. requestAuthority :: Request -> Maybe Authority requestAuthority (Request req) = UTF8.toString <$> getFieldValue tokenAuthority vt where (_, vt) = inpObjHeaders req -- | Getting the scheme from a request. requestScheme :: Request -> Maybe Scheme requestScheme (Request req) = getFieldValue tokenScheme vt where (_, vt) = inpObjHeaders req -- | Getting the headers from a request. requestHeaders :: Request -> TokenHeaderTable requestHeaders (Request req) = inpObjHeaders req -- | Getting the body size from a request. requestBodySize :: Request -> Maybe Int requestBodySize (Request req) = inpObjBodySize req -- | Reading a chunk of the request body. -- An empty 'ByteString' returned when finished. getRequestBodyChunk :: Request -> IO ByteString getRequestBodyChunk = fmap fst . getRequestBodyChunk' -- | Generalization of 'getRequestBodyChunk' which also returns if the 'ByteString' is the final one getRequestBodyChunk' :: Request -> IO (ByteString, Bool) getRequestBodyChunk' (Request req) = inpObjBody req -- | Reading request trailers. -- This function must be called after 'getRequestBodyChunk' -- returns an empty. getRequestTrailers :: Request -> IO (Maybe TokenHeaderTable) getRequestTrailers (Request req) = readIORef (inpObjTrailers req) ---------------------------------------------------------------- -- | Creating response without body. responseNoBody :: H.Status -> H.ResponseHeaders -> Response responseNoBody st hdr = Response $ OutObj hdr' OutBodyNone defaultTrailersMaker where hdr' = setStatus st hdr -- | Creating response with file. responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response responseFile st hdr fileSpec = Response $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker where hdr' = setStatus st hdr -- | Creating response with builder. responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response responseBuilder st hdr builder = Response $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker where hdr' = setStatus st hdr -- | Creating response with streaming. responseStreaming :: H.Status -> H.ResponseHeaders -> ((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 ---------------------------------------------------------------- -- | Getter for response body size. This value is available for file body. responseBodySize :: Response -> Maybe Int responseBodySize (Response (OutObj _ (OutBodyFile (FileSpec _ _ len)) _)) = Just (fromIntegral len) responseBodySize _ = Nothing -- | Setting 'TrailersMaker' to 'Response'. setResponseTrailersMaker :: Response -> TrailersMaker -> Response setResponseTrailersMaker (Response rsp) tm = Response rsp{outObjTrailers = tm} ---------------------------------------------------------------- -- | Creating push promise. -- The third argument is traditional, not used. pushPromise :: ByteString -> Response -> Int -> PushPromise pushPromise path rsp _ = PushPromise path rsp http-semantics-0.3.0/Network/HTTP/Semantics/Server/0000755000000000000000000000000007346545000020252 5ustar0000000000000000http-semantics-0.3.0/Network/HTTP/Semantics/Server/Internal.hs0000644000000000000000000000133107346545000022360 0ustar0000000000000000module Network.HTTP.Semantics.Server.Internal ( Request (..), Response (..), Aux (..), ) where import Network.Socket (SockAddr) import qualified System.TimeManager as T import Network.HTTP.Semantics.Types (InpObj (..), OutObj (..)) -- | Request from client. newtype Request = Request InpObj deriving (Show) -- | Response from server. newtype Response = Response OutObj deriving (Show) -- | Additional information. data Aux = Aux { auxTimeHandle :: T.Handle -- ^ Time handle for the worker processing this request and response. , auxMySockAddr :: SockAddr -- ^ Local socket address copied from 'Config'. , auxPeerSockAddr :: SockAddr -- ^ Remove socket address copied from 'Config'. } http-semantics-0.3.0/Network/HTTP/Semantics/Status.hs0000644000000000000000000000234207346545000020624 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Semantics.Status ( getStatus, setStatus, ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Internal (unsafeCreate) import Data.Word (Word8) import Foreign.Ptr (plusPtr) import Foreign.Storable (poke) import qualified Network.HTTP.Types as H import Network.HTTP.Semantics ---------------------------------------------------------------- getStatus :: TokenHeaderTable -> Maybe H.Status getStatus (_, vt) = getFieldValue tokenStatus vt >>= toStatus setStatus :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders setStatus st hdr = (":status", fromStatus st) : hdr ---------------------------------------------------------------- fromStatus :: H.Status -> ByteString fromStatus status = unsafeCreate 3 $ \p -> do poke p (toW8 r2) poke (p `plusPtr` 1) (toW8 r1) poke (p `plusPtr` 2) (toW8 r0) where toW8 :: Int -> Word8 toW8 n = 48 + fromIntegral n s = H.statusCode status (q0, r0) = s `divMod` 10 (q1, r1) = q0 `divMod` 10 r2 = q1 `mod` 10 toStatus :: ByteString -> Maybe H.Status toStatus bs = case C8.readInt bs of Nothing -> Nothing Just (code, _) -> Just $ toEnum code http-semantics-0.3.0/Network/HTTP/Semantics/Token.hs0000644000000000000000000004513007346545000020423 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} module Network.HTTP.Semantics.Token ( -- * Data type Token (..), tokenCIKey, tokenFoldedKey, toToken, -- * Ix minTokenIx, maxStaticTokenIx, maxTokenIx, cookieTokenIx, -- * Utilities isMaxTokenIx, isCookieTokenIx, isStaticTokenIx, isStaticToken, -- * Defined tokens tokenAuthority, tokenMethod, tokenPath, tokenScheme, tokenStatus, tokenAcceptCharset, tokenAcceptEncoding, tokenAcceptLanguage, tokenAcceptRanges, tokenAccept, tokenAccessControlAllowOrigin, tokenAge, tokenAllow, tokenAuthorization, tokenCacheControl, tokenContentDisposition, tokenContentEncoding, tokenContentLanguage, tokenContentLength, tokenContentLocation, tokenContentRange, tokenContentType, tokenCookie, tokenDate, tokenEtag, tokenExpect, tokenExpires, tokenFrom, tokenHost, tokenIfMatch, tokenIfModifiedSince, tokenIfNoneMatch, tokenIfRange, tokenIfUnmodifiedSince, tokenLastModified, tokenLink, tokenLocation, tokenMaxForwards, tokenProxyAuthenticate, tokenProxyAuthorization, tokenRange, tokenReferer, tokenRefresh, tokenRetryAfter, tokenServer, tokenSetCookie, tokenStrictTransportSecurity, tokenTransferEncoding, tokenUserAgent, tokenVary, tokenVia, tokenWwwAuthenticate, tokenConnection, tokenTE, tokenMax, tokenAccessControlAllowCredentials, tokenAccessControlAllowHeaders, tokenAccessControlAllowMethods, tokenAccessControlExposeHeaders, tokenAccessControlRequestHeaders, tokenAccessControlRequestMethod, tokenAltSvc, tokenContentSecurityPolicy, tokenEarlyData, tokenExpectCt, tokenForwarded, tokenOrigin, tokenPurpose, tokenTimingAllowOrigin, tokenUpgradeInsecureRequests, tokenXContentTypeOptions, tokenXForwardedFor, tokenXFrameOptions, tokenXXssProtection, ) where import qualified Data.ByteString as B import Data.ByteString.Internal (ByteString (..), memcmp) import Data.CaseInsensitive (CI (..), mk, original) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Network.HTTP.Types (HeaderName) import System.IO.Unsafe (unsafeDupablePerformIO) -- $setup -- >>> :set -XOverloadedStrings -- | Internal representation for header keys. data Token = Token { tokenIx :: Int -- ^ Index for value table , shouldBeIndexed :: Bool -- ^ should be indexed in HPACK , isPseudo :: Bool -- ^ is this a pseudo header key? , tokenKey :: HeaderName -- ^ Case insensitive header key } deriving (Eq, Show) -- | Extracting a case insensitive header key from a token. {-# INLINE tokenCIKey #-} tokenCIKey :: Token -> ByteString tokenCIKey (Token _ _ _ ci) = original ci -- | Extracting a folded header key from a token. {-# INLINE tokenFoldedKey #-} tokenFoldedKey :: Token -> ByteString tokenFoldedKey (Token _ _ _ ci) = foldedCase ci {- FOURMOLU_DISABLE -} tokenAuthority :: Token tokenMethod :: Token tokenPath :: Token tokenScheme :: Token tokenStatus :: Token tokenAcceptCharset :: Token tokenAcceptEncoding :: Token tokenAcceptLanguage :: Token tokenAcceptRanges :: Token tokenAccept :: Token tokenAccessControlAllowOrigin :: Token tokenAge :: Token tokenAllow :: Token tokenAuthorization :: Token tokenCacheControl :: Token tokenContentDisposition :: Token tokenContentEncoding :: Token tokenContentLanguage :: Token tokenContentLength :: Token tokenContentLocation :: Token tokenContentRange :: Token tokenContentType :: Token tokenCookie :: Token tokenDate :: Token tokenEtag :: Token tokenExpect :: Token tokenExpires :: Token tokenFrom :: Token tokenHost :: Token tokenIfMatch :: Token tokenIfModifiedSince :: Token tokenIfNoneMatch :: Token tokenIfRange :: Token tokenIfUnmodifiedSince :: Token tokenLastModified :: Token tokenLink :: Token tokenLocation :: Token tokenMaxForwards :: Token tokenProxyAuthenticate :: Token tokenProxyAuthorization :: Token tokenRange :: Token tokenReferer :: Token tokenRefresh :: Token tokenRetryAfter :: Token tokenServer :: Token tokenSetCookie :: Token tokenStrictTransportSecurity :: Token tokenTransferEncoding :: Token tokenUserAgent :: Token tokenVary :: Token tokenVia :: Token tokenWwwAuthenticate :: Token tokenConnection :: Token -- Warp tokenTE :: Token -- Warp tokenAccessControlAllowCredentials :: Token -- QPACK tokenAccessControlAllowHeaders :: Token -- QPACK tokenAccessControlAllowMethods :: Token -- QPACK tokenAccessControlExposeHeaders :: Token -- QPACK tokenAccessControlRequestHeaders :: Token -- QPACK tokenAccessControlRequestMethod :: Token -- QPACK tokenAltSvc :: Token -- QPACK tokenContentSecurityPolicy :: Token -- QPACK tokenEarlyData :: Token -- QPACK tokenExpectCt :: Token -- QPACK tokenForwarded :: Token -- QPACK tokenOrigin :: Token -- QPACK tokenPurpose :: Token -- QPACK tokenTimingAllowOrigin :: Token -- QPACK tokenUpgradeInsecureRequests :: Token -- QPACK tokenXContentTypeOptions :: Token -- QPACK tokenXForwardedFor :: Token -- QPACK tokenXFrameOptions :: Token -- QPACK tokenXXssProtection :: Token -- QPACK tokenMax :: Token -- Other tokens tokenAuthority = Token 0 True True ":authority" tokenMethod = Token 1 True True ":method" tokenPath = Token 2 False True ":path" tokenScheme = Token 3 True True ":scheme" tokenStatus = Token 4 True True ":status" tokenAcceptCharset = Token 5 True False "Accept-Charset" tokenAcceptEncoding = Token 6 True False "Accept-Encoding" tokenAcceptLanguage = Token 7 True False "Accept-Language" tokenAcceptRanges = Token 8 True False "Accept-Ranges" tokenAccept = Token 9 True False "Accept" tokenAccessControlAllowOrigin = Token 10 True False "Access-Control-Allow-Origin" tokenAge = Token 11 True False "Age" tokenAllow = Token 12 True False "Allow" tokenAuthorization = Token 13 True False "Authorization" tokenCacheControl = Token 14 True False "Cache-Control" tokenContentDisposition = Token 15 True False "Content-Disposition" tokenContentEncoding = Token 16 True False "Content-Encoding" tokenContentLanguage = Token 17 True False "Content-Language" tokenContentLength = Token 18 False False "Content-Length" tokenContentLocation = Token 19 False False "Content-Location" tokenContentRange = Token 20 True False "Content-Range" tokenContentType = Token 21 True False "Content-Type" tokenCookie = Token 22 True False "Cookie" tokenDate = Token 23 True False "Date" tokenEtag = Token 24 False False "Etag" tokenExpect = Token 25 True False "Expect" tokenExpires = Token 26 True False "Expires" tokenFrom = Token 27 True False "From" tokenHost = Token 28 True False "Host" tokenIfMatch = Token 29 True False "If-Match" tokenIfModifiedSince = Token 30 True False "If-Modified-Since" tokenIfNoneMatch = Token 31 True False "If-None-Match" tokenIfRange = Token 32 True False "If-Range" tokenIfUnmodifiedSince = Token 33 True False "If-Unmodified-Since" tokenLastModified = Token 34 True False "Last-Modified" tokenLink = Token 35 True False "Link" tokenLocation = Token 36 True False "Location" tokenMaxForwards = Token 37 True False "Max-Forwards" tokenProxyAuthenticate = Token 38 True False "Proxy-Authenticate" tokenProxyAuthorization = Token 39 True False "Proxy-Authorization" tokenRange = Token 40 True False "Range" tokenReferer = Token 41 True False "Referer" tokenRefresh = Token 42 True False "Refresh" tokenRetryAfter = Token 43 True False "Retry-After" tokenServer = Token 44 True False "Server" tokenSetCookie = Token 45 False False "Set-Cookie" tokenStrictTransportSecurity = Token 46 True False "Strict-Transport-Security" tokenTransferEncoding = Token 47 True False "Transfer-Encoding" tokenUserAgent = Token 48 True False "User-Agent" tokenVary = Token 49 True False "Vary" tokenVia = Token 50 True False "Via" tokenWwwAuthenticate = Token 51 True False "Www-Authenticate" -- | A place holder to hold header keys not defined in the static table. -- | For Warp tokenConnection = Token 52 False False "Connection" tokenTE = Token 53 False False "TE" -- | For QPACK tokenAccessControlAllowCredentials = Token 54 True False "Access-Control-Allow-Credentials" tokenAccessControlAllowHeaders = Token 55 True False "Access-Control-Allow-Headers" tokenAccessControlAllowMethods = Token 56 True False "Access-Control-Allow-Methods" tokenAccessControlExposeHeaders = Token 57 True False "Access-Control-Expose-Headers" tokenAccessControlRequestHeaders = Token 58 True False "Access-Control-Request-Headers" tokenAccessControlRequestMethod = Token 59 True False "Access-Control-Request-Method" tokenAltSvc = Token 60 True False "Alt-Svc" tokenContentSecurityPolicy = Token 61 True False "Content-Security-Policy" tokenEarlyData = Token 62 True False "Early-Data" tokenExpectCt = Token 63 True False "Expect-Ct" tokenForwarded = Token 64 True False "Forwarded" tokenOrigin = Token 65 True False "Origin" tokenPurpose = Token 66 True False "Purpose" tokenTimingAllowOrigin = Token 67 True False "Timing-Allow-Origin" tokenUpgradeInsecureRequests = Token 68 True False "Upgrade-Insecure-Requests" tokenXContentTypeOptions = Token 69 True False "X-Content-Type-Options" tokenXForwardedFor = Token 70 True False "X-Forwarded-For" tokenXFrameOptions = Token 71 True False "X-Frame-Options" tokenXXssProtection = Token 72 True False "X-Xss-Protection" tokenMax = Token 73 True False "for other tokens" {- FOURMOLU_ENABLE -} -- | Minimum token index. minTokenIx :: Int minTokenIx = 0 -- | Maximun token index defined in the static table. maxStaticTokenIx :: Int maxStaticTokenIx = 51 -- | Maximum token index. maxTokenIx :: Int maxTokenIx = 73 -- | Token index for 'tokenCookie'. cookieTokenIx :: Int cookieTokenIx = 22 -- | Is this token ix for Cookie? {-# INLINE isCookieTokenIx #-} isCookieTokenIx :: Int -> Bool isCookieTokenIx n = n == cookieTokenIx -- | Is this token ix to be held in the place holder? {-# INLINE isMaxTokenIx #-} isMaxTokenIx :: Int -> Bool isMaxTokenIx n = n == maxTokenIx -- | Is this token ix for a header not defined in the static table? {-# INLINE isStaticTokenIx #-} isStaticTokenIx :: Int -> Bool isStaticTokenIx n = n <= maxStaticTokenIx -- | Is this token for a header not defined in the static table? {-# INLINE isStaticToken #-} isStaticToken :: Token -> Bool isStaticToken n = tokenIx n <= maxStaticTokenIx -- | Making a token from a header key. -- -- >>> toToken ":authority" == tokenAuthority -- True -- >>> toToken "foo" -- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"} -- >>> toToken ":bar" -- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = True, tokenKey = ":bar"} toToken :: ByteString -> Token toToken "" = Token maxTokenIx True False "" toToken bs = case len of 2 -> if bs === "te" then tokenTE else mkTokenMax bs 3 -> case lst of 97 | bs === "via" -> tokenVia 101 | bs === "age" -> tokenAge _ -> mkTokenMax bs 4 -> case lst of 101 | bs === "date" -> tokenDate 103 | bs === "etag" -> tokenEtag 107 | bs === "link" -> tokenLink 109 | bs === "from" -> tokenFrom 116 | bs === "host" -> tokenHost 121 | bs === "vary" -> tokenVary _ -> mkTokenMax bs 5 -> case lst of 101 | bs === "range" -> tokenRange 104 | bs === ":path" -> tokenPath 119 | bs === "allow" -> tokenAllow _ -> mkTokenMax bs 6 -> case lst of 101 | bs === "cookie" -> tokenCookie 110 | bs === "origin" -> tokenOrigin 114 | bs === "server" -> tokenServer 116 | bs === "expect" -> tokenExpect | bs === "accept" -> tokenAccept _ -> mkTokenMax bs 7 -> case lst of 99 | bs === "alt-svc" -> tokenAltSvc 100 | bs === ":method" -> tokenMethod 101 | bs === ":scheme" -> tokenScheme | bs === "purpose" -> tokenPurpose 104 | bs === "refresh" -> tokenRefresh 114 | bs === "referer" -> tokenReferer 115 | bs === "expires" -> tokenExpires | bs === ":status" -> tokenStatus _ -> mkTokenMax bs 8 -> case lst of 101 | bs === "if-range" -> tokenIfRange 104 | bs === "if-match" -> tokenIfMatch 110 | bs === "location" -> tokenLocation _ -> mkTokenMax bs 9 -> case lst of 100 | bs === "forwarded" -> tokenForwarded 116 | bs === "expect-ct" -> tokenExpectCt _ -> mkTokenMax bs 10 -> case lst of 97 | bs === "early-data" -> tokenEarlyData 101 | bs === "set-cookie" -> tokenSetCookie 110 | bs === "connection" -> tokenConnection 116 | bs === "user-agent" -> tokenUserAgent 121 | bs === ":authority" -> tokenAuthority _ -> mkTokenMax bs 11 -> case lst of 114 | bs === "retry-after" -> tokenRetryAfter _ -> mkTokenMax bs 12 -> case lst of 101 | bs === "content-type" -> tokenContentType 115 | bs === "max-forwards" -> tokenMaxForwards _ -> mkTokenMax bs 13 -> case lst of 100 | bs === "last-modified" -> tokenLastModified 101 | bs === "content-range" -> tokenContentRange 104 | bs === "if-none-match" -> tokenIfNoneMatch 108 | bs === "cache-control" -> tokenCacheControl 110 | bs === "authorization" -> tokenAuthorization 115 | bs === "accept-ranges" -> tokenAcceptRanges _ -> mkTokenMax bs 14 -> case lst of 104 | bs === "content-length" -> tokenContentLength 116 | bs === "accept-charset" -> tokenAcceptCharset _ -> mkTokenMax bs 15 -> case lst of 101 | bs === "accept-language" -> tokenAcceptLanguage 103 | bs === "accept-encoding" -> tokenAcceptEncoding 114 | bs === "x-forwarded-for" -> tokenXForwardedFor 115 | bs === "x-frame-options" -> tokenXFrameOptions _ -> mkTokenMax bs 16 -> case lst of 101 | bs === "content-language" -> tokenContentLanguage | bs === "www-authenticate" -> tokenWwwAuthenticate 103 | bs === "content-encoding" -> tokenContentEncoding 110 | bs === "content-location" -> tokenContentLocation | bs === "x-xss-protection" -> tokenXXssProtection _ -> mkTokenMax bs 17 -> case lst of 101 | bs === "if-modified-since" -> tokenIfModifiedSince 103 | bs === "transfer-encoding" -> tokenTransferEncoding _ -> mkTokenMax bs 18 -> case lst of 101 | bs === "proxy-authenticate" -> tokenProxyAuthenticate _ -> mkTokenMax bs 19 -> case lst of 101 | bs === "if-unmodified-since" -> tokenIfUnmodifiedSince 110 | bs === "proxy-authorization" -> tokenProxyAuthorization | bs === "content-disposition" -> tokenContentDisposition | bs === "timing-allow-origin" -> tokenTimingAllowOrigin _ -> mkTokenMax bs 22 -> case lst of 115 | bs === "x-content-type-options" -> tokenXContentTypeOptions _ -> mkTokenMax bs 23 -> case lst of 121 | bs === "content-security-policy" -> tokenContentSecurityPolicy _ -> mkTokenMax bs 25 -> case lst of 115 | bs === "upgrade-insecure-requests" -> tokenUpgradeInsecureRequests 121 | bs === "strict-transport-security" -> tokenStrictTransportSecurity _ -> mkTokenMax bs 27 -> case lst of 110 | bs === "access-control-allow-origin" -> tokenAccessControlAllowOrigin _ -> mkTokenMax bs 28 -> case lst of 115 | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders | bs === "access-control-allow-methods" -> tokenAccessControlAllowMethods _ -> mkTokenMax bs 29 -> case lst of 100 | bs === "access-control-request-method" -> tokenAccessControlRequestMethod 115 | bs === "access-control-expose-headers" -> tokenAccessControlExposeHeaders _ -> mkTokenMax bs 30 -> case lst of 115 | bs === "access-control-request-headers" -> tokenAccessControlRequestHeaders _ -> mkTokenMax bs 32 -> case lst of 115 | bs === "access-control-allow-credentials" -> tokenAccessControlAllowCredentials _ -> mkTokenMax bs _ -> mkTokenMax bs where len = B.length bs lst = B.last bs PS fp1 off1 siz === PS fp2 off2 _ = unsafeDupablePerformIO $ withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> do i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz return $ i == 0 mkTokenMax :: ByteString -> Token mkTokenMax bs = Token maxTokenIx True p (mk bs) where p | B.length bs == 0 = False | B.head bs == 58 = True | otherwise = False http-semantics-0.3.0/Network/HTTP/Semantics/Trailer.hs0000644000000000000000000000364607346545000020753 0ustar0000000000000000module Network.HTTP.Semantics.Trailer where import Network.ByteOrder import qualified Network.HTTP.Types as H -- | Trailers maker. A chunks of the response body is passed -- with 'Just'. The maker should update internal state -- with the 'ByteString' and return the next trailers maker. -- When response body reaches its end, -- 'Nothing' is passed and the maker should generate -- trailers. An example: -- -- > {-# LANGUAGE BangPatterns #-} -- > import Data.ByteString (ByteString) -- > import qualified Data.ByteString.Char8 as C8 -- > import Crypto.Hash (Context, SHA1) -- cryptonite -- > import qualified Crypto.Hash as CH -- > -- > -- Strictness is important for Context. -- > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker -- > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] -- > where -- > !sha1 = C8.pack $ show $ CH.hashFinalize ctx -- > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' -- > where -- > !ctx' = CH.hashUpdate ctx bs -- -- Usage example: -- -- > let h2rsp = responseFile ... -- > maker = trailersMaker (CH.hashInit :: Context SHA1) -- > h2rsp' = setResponseTrailersMaker h2rsp maker type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker -- | TrailersMake to create no trailers. defaultTrailersMaker :: TrailersMaker defaultTrailersMaker Nothing = return $ Trailers [] defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker -- | Either the next trailers maker or final trailers. data NextTrailersMaker = NextTrailersMaker TrailersMaker | Trailers [H.Header] ---------------------------------------------------------------- -- | Running trailers-maker. -- -- > bufferIO buf siz $ \bs -> tlrmkr (Just bs) runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs) http-semantics-0.3.0/Network/HTTP/Semantics/Types.hs0000644000000000000000000001137007346545000020446 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Network.HTTP.Semantics.Types ( -- * Request/response as input InpObj (..), InpBody, -- * Request/response as output OutObj (..), OutBody (..), OutBodyIface (..), -- * Trailers maker TrailersMaker, defaultTrailersMaker, NextTrailersMaker (..), -- * File spec FileOffset, ByteCount, FileSpec (..), -- * Types Scheme, Authority, Path, ) where import Control.Exception (SomeException) import Data.ByteString.Builder (Builder) import Data.IORef import Data.Int (Int64) import Network.ByteOrder import qualified Network.HTTP.Types as H import Network.HTTP.Semantics.Header import Network.HTTP.Semantics.Trailer ---------------------------------------------------------------- -- | "http" or "https". type Scheme = ByteString -- | Authority. type Authority = String -- | Path. type Path = ByteString ---------------------------------------------------------------- type InpBody = IO (ByteString, Bool) data OutBody = OutBodyNone | -- | Streaming body takes a write action and a flush action. OutBodyStreaming ((Builder -> IO ()) -> IO () -> 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 -- -- In @http2@, there is no direct correspondence between chunks and the -- resulting @DATA@ frames sent: the chunks are collected (written to an -- internal write buffer) until we can fill a frame. -- -- See also 'outBodyFlush'. , outBodyPushFinal :: Builder -> IO () -- ^ Push the final chunk -- -- 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. , 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 -- ). If 'Nothing' -- is given, the error code will be @CANCEL@. -- -- If there is a partially constructed @DATA@ frame at the time of -- cancellation, this frame is discarded. If this is undesirable, you should -- call 'outBodyFlush' prior to cancelling. , outBodyFlush :: IO () -- ^ Flush -- -- This can be used to emit a DATA frame with the data collected so far -- (using 'outBodyPush'), even if that DATA frame has not yet reached the -- maximum frame size. Calling 'outBodyFlush' unnecessarily can therefore -- result in excessive overhead from frame headers. -- -- If no data is available to send, this is a no-op. } -- | Input object data InpObj = InpObj { inpObjHeaders :: TokenHeaderTable -- ^ Accessor for headers. , inpObjBodySize :: Maybe Int -- ^ Accessor for body length specified in content-length:. , inpObjBody :: InpBody -- ^ Accessor for body. , inpObjTrailers :: IORef (Maybe TokenHeaderTable) -- ^ Accessor for trailers. } instance Show InpObj where show (InpObj (thl, _) _ _body _tref) = show thl -- | Output object data OutObj = OutObj { outObjHeaders :: [H.Header] -- ^ Accessor for header. , outObjBody :: OutBody -- ^ Accessor for outObj body. , outObjTrailers :: TrailersMaker -- ^ Accessor for trailers maker. } instance Show OutObj where show (OutObj hdr _ _) = show hdr ---------------------------------------------------------------- -- | Offset for file. type FileOffset = Int64 -- | How many bytes to read type ByteCount = Int64 -- | File specification. data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show) http-semantics-0.3.0/http-semantics.cabal0000644000000000000000000000274007346545000016600 0ustar0000000000000000cabal-version: 3.0 name: http-semantics version: 0.3.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 location: https://github.com/kazu-yamamoto/http-semantics library exposed-modules: Network.HTTP.Semantics Network.HTTP.Semantics.Client Network.HTTP.Semantics.Client.Internal Network.HTTP.Semantics.IO Network.HTTP.Semantics.Server Network.HTTP.Semantics.Server.Internal Network.HTTP.Semantics.Token other-modules: Network.HTTP.Semantics.File Network.HTTP.Semantics.FillBuf Network.HTTP.Semantics.Header Network.HTTP.Semantics.ReadN Network.HTTP.Semantics.Status Network.HTTP.Semantics.Trailer Network.HTTP.Semantics.Types default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall build-depends: base >=4.9 && <5, array, bytestring >=0.10, case-insensitive, http-types >=0.12 && <0.13, network, network-byte-order, time-manager, utf8-string