packages feed

http-semantics (empty) → 0.0.0

raw patch · 16 files changed

+1527/−0 lines, 16 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, case-insensitive, http-types, network, network-byte-order, time-manager, utf8-string

Files

+ LICENSE view
@@ -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.
+ Network/HTTP/Semantics.hs view
@@ -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
+ Network/HTTP/Semantics/Client.hs view
@@ -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)
+ Network/HTTP/Semantics/Client/Internal.hs view
@@ -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.+    }
+ Network/HTTP/Semantics/File.hs view
@@ -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)
+ Network/HTTP/Semantics/FillBuf.hs view
@@ -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
+ Network/HTTP/Semantics/Header.hs view
@@ -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
+ Network/HTTP/Semantics/IO.hs view
@@ -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
+ Network/HTTP/Semantics/ReadN.hs view
@@ -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
+ Network/HTTP/Semantics/Server.hs view
@@ -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
+ Network/HTTP/Semantics/Server/Internal.hs view
@@ -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'.+    }
+ Network/HTTP/Semantics/Status.hs view
@@ -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
+ Network/HTTP/Semantics/Token.hs view
@@ -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
+ Network/HTTP/Semantics/Trailer.hs view
@@ -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)
+ Network/HTTP/Semantics/Types.hs view
@@ -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)
+ http-semantics.cabal view
@@ -0,0 +1,52 @@+cabal-version:      >=1.10+name:               http-semantics+version:            0.0.0+license:            BSD3+license-file:       LICENSE+maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>+author:             Kazu Yamamoto <kazu@iij.ad.jp>+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+