diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (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. diff --git a/Network/HTTP/Semantics.hs b/Network/HTTP/Semantics.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics.hs @@ -0,0 +1,10 @@ +-- | 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 diff --git a/Network/HTTP/Semantics/Client.hs b/Network/HTTP/Semantics/Client.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Client.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Network.HTTP.Semantics.Client ( + -- * HTTP client + Client, + SendRequest, + + -- * Request + Request, + + -- * Creating request + requestNoBody, + requestFile, + requestStreaming, + requestStreamingUnmask, + requestBuilder, + + -- ** Trailers maker + TrailersMaker, + NextTrailersMaker (..), + defaultTrailersMaker, + setRequestTrailersMaker, + + -- * Response + Response, + + -- ** Accessing response + responseStatus, + responseHeaders, + responseBodySize, + 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 = Request $ OutObj hdr' (OutBodyStreamingUnmask 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 (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) diff --git a/Network/HTTP/Semantics/Client/Internal.hs b/Network/HTTP/Semantics/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Client/Internal.hs @@ -0,0 +1,19 @@ +module 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. + } diff --git a/Network/HTTP/Semantics/File.hs b/Network/HTTP/Semantics/File.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/File.hs @@ -0,0 +1,38 @@ +module 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) diff --git a/Network/HTTP/Semantics/FillBuf.hs b/Network/HTTP/Semantics/FillBuf.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/FillBuf.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.HTTP.Semantics.FillBuf ( + -- * Filling a buffer + Next (..), + DynaNext, + BytesFilled, + StreamingChunk (..), + fillBuilderBodyGetNext, + fillFileBodyGetNext, + fillStreamBodyGetNext, +) where + +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 Foreign.Ptr (plusPtr) +import Network.ByteOrder +import Network.HTTP.Semantics.Client + +---------------------------------------------------------------- + +-- type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next +type DynaNext = Buffer -> BufferSize -> Int -> IO Next + +type BytesFilled = Int + +data Next + = Next + BytesFilled -- payload length + Bool -- require flushing + (Maybe DynaNext) + +---------------------------------------------------------------- + +data Leftover + = LZero + | LOne B.BufferWriter + | LTwo ByteString B.BufferWriter + +---------------------------------------------------------------- + +data StreamingChunk + = StreamingFinished (IO ()) + | StreamingFlush + | StreamingBuilder Builder + +---------------------------------------------------------------- + +fillBuilderBodyGetNext :: Builder -> DynaNext +fillBuilderBodyGetNext bb buf siz lim = do + let room = min siz lim + (len, signal) <- B.runBuilder bb buf room + return $ nextForBuilder len signal + +fillFileBodyGetNext + :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext +fillFileBodyGetNext pread start bytecount refresh buf siz lim = do + let room = min siz lim + len <- pread start (mini room bytecount) buf + let len' = fromIntegral len + return $ nextForFile len' pread (start + len) (bytecount - len) refresh + +fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext +fillStreamBodyGetNext takeQ buf siz lim = do + let room = min siz lim + (cont, len, reqflush, leftover) <- runStreamBuilder buf room takeQ + return $ nextForStream cont len reqflush leftover takeQ + +---------------------------------------------------------------- + +fillBufBuilder :: Leftover -> DynaNext +fillBufBuilder leftover buf0 siz0 lim = do + let room = min siz0 lim + case leftover of + LZero -> error "fillBufBuilder: LZero" + LOne writer -> do + (len, signal) <- writer buf0 room + getNext len signal + LTwo bs writer + | BS.length bs <= room -> do + buf1 <- copy buf0 bs + let len1 = BS.length bs + (len2, signal) <- writer buf1 (room - len1) + getNext (len1 + len2) signal + | otherwise -> do + let (bs1, bs2) = BS.splitAt room bs + void $ copy buf0 bs1 + getNext room (B.Chunk bs2 writer) + where + getNext l s = return $ nextForBuilder l s + +nextForBuilder :: BytesFilled -> B.Next -> Next +nextForBuilder len B.Done = + Next len True Nothing -- let's flush +nextForBuilder len (B.More _ writer) = + Next len False $ Just (fillBufBuilder (LOne writer)) +nextForBuilder len (B.Chunk bs writer) = + Next len False $ Just (fillBufBuilder (LTwo bs writer)) + +---------------------------------------------------------------- + +runStreamBuilder + :: Buffer + -> BufferSize + -> IO (Maybe StreamingChunk) + -> IO + ( Bool -- continue + , BytesFilled + , Bool -- require flusing + , Leftover + ) +runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0 + where + loop buf room total = do + mbuilder <- takeQ + case mbuilder of + Nothing -> return (True, total, False, LZero) + Just (StreamingBuilder builder) -> do + (len, signal) <- B.runBuilder builder buf room + let total' = total + len + case signal of + B.Done -> loop (buf `plusPtr` len) (room - len) total' + B.More _ writer -> return (True, total', False, LOne writer) + B.Chunk bs writer -> return (True, total', False, LTwo bs writer) + Just StreamingFlush -> return (True, total, True, LZero) + Just (StreamingFinished dec) -> do + dec + return (False, total, True, LZero) + +fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext +fillBufStream leftover0 takeQ buf0 siz0 lim0 = do + let room0 = min siz0 lim0 + case leftover0 of + LZero -> do + (cont, len, reqflush, leftover) <- runStreamBuilder buf0 room0 takeQ + getNext cont len reqflush leftover + LOne writer -> write writer buf0 room0 0 + LTwo bs writer + | BS.length bs <= room0 -> do + buf1 <- copy buf0 bs + let len = BS.length bs + write writer buf1 (room0 - len) len + | otherwise -> do + let (bs1, bs2) = BS.splitAt room0 bs + void $ copy buf0 bs1 + getNext True room0 False $ LTwo bs2 writer + where + getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next + getNext cont len reqflush l = return $ nextForStream cont len reqflush l takeQ + + write + :: (Buffer -> BufferSize -> IO (Int, B.Next)) + -> Buffer + -> BufferSize + -> Int + -> IO Next + write writer1 buf room sofar = do + (len, signal) <- writer1 buf room + case signal of + B.Done -> do + (cont, extra, reqflush, leftover) <- + runStreamBuilder (buf `plusPtr` len) (room - len) takeQ + let total = sofar + len + extra + getNext cont total reqflush leftover + B.More _ writer -> do + let total = sofar + len + getNext True total False $ LOne writer + B.Chunk bs writer -> do + let total = sofar + len + getNext True total False $ LTwo bs writer + +nextForStream + :: Bool + -> BytesFilled + -> Bool + -> Leftover + -> IO (Maybe StreamingChunk) + -> Next +nextForStream False len reqflush _ _ = Next len reqflush Nothing +nextForStream True len reqflush leftOrZero takeQ = + Next len reqflush $ Just (fillBufStream leftOrZero takeQ) + +---------------------------------------------------------------- + +fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext +fillBufFile pread start bytes refresh buf siz lim = do + let room = min siz lim + len <- pread start (mini room bytes) buf + refresh + let len' = fromIntegral len + return $ nextForFile len' pread (start + len) (bytes - len) refresh + +nextForFile + :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next +nextForFile 0 _ _ _ _ = Next 0 True Nothing -- let's flush +nextForFile len _ _ 0 _ = Next len False Nothing +nextForFile len pread start bytes refresh = + 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 diff --git a/Network/HTTP/Semantics/Header.hs b/Network/HTTP/Semantics/Header.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Header.hs @@ -0,0 +1,66 @@ +module 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 diff --git a/Network/HTTP/Semantics/IO.hs b/Network/HTTP/Semantics/IO.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/IO.hs @@ -0,0 +1,11 @@ +module 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 diff --git a/Network/HTTP/Semantics/ReadN.hs b/Network/HTTP/Semantics/ReadN.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/ReadN.hs @@ -0,0 +1,48 @@ +module 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. +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 diff --git a/Network/HTTP/Semantics/Server.hs b/Network/HTTP/Semantics/Server.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Server.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Semantics.Server ( + -- * HTTP server + Server, + + -- * Request + Request, + + -- ** Accessing request + requestMethod, + requestPath, + requestAuthority, + requestScheme, + requestHeaders, + requestBodySize, + getRequestBodyChunk, + getRequestTrailers, + + -- * Aux + Aux, + auxTimeHandle, + auxMySockAddr, + auxPeerSockAddr, + + -- * Response + Response, + + -- ** Creating response + responseNoBody, + responseFile, + responseStreaming, + responseBuilder, + + -- ** 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. +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 (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 + +---------------------------------------------------------------- + +-- | 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 diff --git a/Network/HTTP/Semantics/Server/Internal.hs b/Network/HTTP/Semantics/Server/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Server/Internal.hs @@ -0,0 +1,26 @@ +module 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'. + } diff --git a/Network/HTTP/Semantics/Status.hs b/Network/HTTP/Semantics/Status.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Status.hs @@ -0,0 +1,44 @@ +{-# 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 diff --git a/Network/HTTP/Semantics/Token.hs b/Network/HTTP/Semantics/Token.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Token.hs @@ -0,0 +1,487 @@ +{-# 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 diff --git a/Network/HTTP/Semantics/Trailer.hs b/Network/HTTP/Semantics/Trailer.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Trailer.hs @@ -0,0 +1,51 @@ +module 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) diff --git a/Network/HTTP/Semantics/Types.hs b/Network/HTTP/Semantics/Types.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Semantics/Types.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RankNTypes #-} + +module Network.HTTP.Semantics.Types ( + -- * Request/response as input + InpObj (..), + InpBody, + + -- * Request/response as output + OutObj (..), + OutBody (..), + + -- * Trailers maker + TrailersMaker, + defaultTrailersMaker, + NextTrailersMaker (..), + + -- * File spec + FileOffset, + ByteCount, + FileSpec (..), + + -- * Types + Scheme, + Authority, + Path, +) where + +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 + +data OutBody + = 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 + ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) + | OutBodyBuilder Builder + | OutBodyFile FileSpec + +-- | 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) diff --git a/http-semantics.cabal b/http-semantics.cabal new file mode 100644 --- /dev/null +++ b/http-semantics.cabal @@ -0,0 +1,52 @@ +cabal-version: >=1.10 +name: http-semantics +version: 0.0.0 +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 + +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 +