{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Semantics.Server (
    -- * HTTP server
    Server,

    -- * Request
    Request,

    -- ** Accessing request
    requestMethod,
    requestPath,
    requestAuthority,
    requestScheme,
    requestHeaders,
    requestBodySize,
    getRequestBodyChunk,
    getRequestBodyChunk',
    getRequestTrailers,

    -- * Aux
    Aux,
    auxTimeHandle,
    auxMySockAddr,
    auxPeerSockAddr,

    -- * Response
    Response,

    -- ** Creating response
    responseNoBody,
    responseFile,
    responseStreaming,
    responseBuilder,

    -- ** 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
    { PushPromise -> ByteString
promiseRequestPath :: ByteString
    -- ^ Accessor for a URL path in a push promise (a virtual request from a server).
    --   E.g. \"\/style\/default.css\".
    , PushPromise -> Response
promiseResponse :: Response
    -- ^ Accessor for response actually pushed from a server.
    }

----------------------------------------------------------------

-- | Getting the method from a request.
requestMethod :: Request -> Maybe H.Method
requestMethod :: Request -> Maybe ByteString
requestMethod (Request InpObj
req) = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenMethod ValueTable
vt
  where
    (TokenHeaderList
_, ValueTable
vt) = InpObj -> (TokenHeaderList, ValueTable)
inpObjHeaders InpObj
req

-- | Getting the path from a request.
requestPath :: Request -> Maybe Path
requestPath :: Request -> Maybe ByteString
requestPath (Request InpObj
req) = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenPath ValueTable
vt
  where
    (TokenHeaderList
_, ValueTable
vt) = InpObj -> (TokenHeaderList, ValueTable)
inpObjHeaders InpObj
req

-- | Getting the authority from a request.
requestAuthority :: Request -> Maybe Authority
requestAuthority :: Request -> Maybe Authority
requestAuthority (Request InpObj
req) = ByteString -> Authority
UTF8.toString (ByteString -> Authority) -> Maybe ByteString -> Maybe Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenAuthority ValueTable
vt
  where
    (TokenHeaderList
_, ValueTable
vt) = InpObj -> (TokenHeaderList, ValueTable)
inpObjHeaders InpObj
req

-- | Getting the scheme from a request.
requestScheme :: Request -> Maybe Scheme
requestScheme :: Request -> Maybe ByteString
requestScheme (Request InpObj
req) = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenScheme ValueTable
vt
  where
    (TokenHeaderList
_, ValueTable
vt) = InpObj -> (TokenHeaderList, ValueTable)
inpObjHeaders InpObj
req

-- | Getting the headers from a request.
requestHeaders :: Request -> TokenHeaderTable
requestHeaders :: Request -> (TokenHeaderList, ValueTable)
requestHeaders (Request InpObj
req) = InpObj -> (TokenHeaderList, ValueTable)
inpObjHeaders InpObj
req

-- | Getting the body size from a request.
requestBodySize :: Request -> Maybe Int
requestBodySize :: Request -> Maybe Int
requestBodySize (Request InpObj
req) = InpObj -> Maybe Int
inpObjBodySize InpObj
req

-- | Reading a chunk of the request body.
--   An empty 'ByteString' returned when finished.
getRequestBodyChunk :: Request -> IO ByteString
getRequestBodyChunk :: Request -> IO ByteString
getRequestBodyChunk = ((ByteString, Bool) -> ByteString)
-> IO (ByteString, Bool) -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Bool) -> ByteString
forall a b. (a, b) -> a
fst (IO (ByteString, Bool) -> IO ByteString)
-> (Request -> IO (ByteString, Bool)) -> Request -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO (ByteString, Bool)
getRequestBodyChunk'

-- | Generalization of 'getRequestBodyChunk' which also returns if the 'ByteString' is the final one
getRequestBodyChunk' :: Request -> IO (ByteString, Bool)
getRequestBodyChunk' :: Request -> IO (ByteString, Bool)
getRequestBodyChunk' (Request InpObj
req) = InpObj -> IO (ByteString, Bool)
inpObjBody InpObj
req

-- | Reading request trailers.
--   This function must be called after 'getRequestBodyChunk'
--   returns an empty.
getRequestTrailers :: Request -> IO (Maybe TokenHeaderTable)
getRequestTrailers :: Request -> IO (Maybe (TokenHeaderList, ValueTable))
getRequestTrailers (Request InpObj
req) = IORef (Maybe (TokenHeaderList, ValueTable))
-> IO (Maybe (TokenHeaderList, ValueTable))
forall a. IORef a -> IO a
readIORef (InpObj -> IORef (Maybe (TokenHeaderList, ValueTable))
inpObjTrailers InpObj
req)

----------------------------------------------------------------

-- | Creating response without body.
responseNoBody :: H.Status -> H.ResponseHeaders -> Response
responseNoBody :: Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
hdr = OutObj -> Response
Response (OutObj -> Response) -> OutObj -> Response
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> OutBody -> TrailersMaker -> OutObj
OutObj ResponseHeaders
hdr' OutBody
OutBodyNone TrailersMaker
defaultTrailersMaker
  where
    hdr' :: ResponseHeaders
hdr' = Status -> ResponseHeaders -> ResponseHeaders
setStatus Status
st ResponseHeaders
hdr

-- | Creating response with file.
responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response
responseFile :: Status -> ResponseHeaders -> FileSpec -> Response
responseFile Status
st ResponseHeaders
hdr FileSpec
fileSpec = OutObj -> Response
Response (OutObj -> Response) -> OutObj -> Response
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> OutBody -> TrailersMaker -> OutObj
OutObj ResponseHeaders
hdr' (FileSpec -> OutBody
OutBodyFile FileSpec
fileSpec) TrailersMaker
defaultTrailersMaker
  where
    hdr' :: ResponseHeaders
hdr' = Status -> ResponseHeaders -> ResponseHeaders
setStatus Status
st ResponseHeaders
hdr

-- | Creating response with builder.
responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response
responseBuilder :: Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
st ResponseHeaders
hdr Builder
builder = OutObj -> Response
Response (OutObj -> Response) -> OutObj -> Response
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> OutBody -> TrailersMaker -> OutObj
OutObj ResponseHeaders
hdr' (Builder -> OutBody
OutBodyBuilder Builder
builder) TrailersMaker
defaultTrailersMaker
  where
    hdr' :: ResponseHeaders
hdr' = Status -> ResponseHeaders -> ResponseHeaders
setStatus Status
st ResponseHeaders
hdr

-- | Creating response with streaming.
responseStreaming
    :: H.Status
    -> H.ResponseHeaders
    -> ((Builder -> IO ()) -> IO () -> IO ())
    -> Response
responseStreaming :: Status
-> ResponseHeaders
-> ((Builder -> IO ()) -> IO () -> IO ())
-> Response
responseStreaming Status
st ResponseHeaders
hdr (Builder -> IO ()) -> IO () -> IO ()
strmbdy = OutObj -> Response
Response (OutObj -> Response) -> OutObj -> Response
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> OutBody -> TrailersMaker -> OutObj
OutObj ResponseHeaders
hdr' (((Builder -> IO ()) -> IO () -> IO ()) -> OutBody
OutBodyStreaming (Builder -> IO ()) -> IO () -> IO ()
strmbdy) TrailersMaker
defaultTrailersMaker
  where
    hdr' :: ResponseHeaders
hdr' = Status -> ResponseHeaders -> ResponseHeaders
setStatus Status
st ResponseHeaders
hdr

----------------------------------------------------------------

-- | Getter for response body size. This value is available for file body.
responseBodySize :: Response -> Maybe Int
responseBodySize :: Response -> Maybe Int
responseBodySize (Response (OutObj ResponseHeaders
_ (OutBodyFile (FileSpec Authority
_ ByteCount
_ ByteCount
len)) TrailersMaker
_)) = Int -> Maybe Int
forall a. a -> Maybe a
Just (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
len)
responseBodySize Response
_ = Maybe Int
forall a. Maybe a
Nothing

-- | Setting 'TrailersMaker' to 'Response'.
setResponseTrailersMaker :: Response -> TrailersMaker -> Response
setResponseTrailersMaker :: Response -> TrailersMaker -> Response
setResponseTrailersMaker (Response OutObj
rsp) TrailersMaker
tm = OutObj -> Response
Response OutObj
rsp{outObjTrailers = tm}

----------------------------------------------------------------

-- | Creating push promise.
--   The third argument is traditional, not used.
pushPromise :: ByteString -> Response -> Int -> PushPromise
pushPromise :: ByteString -> Response -> Int -> PushPromise
pushPromise ByteString
path Response
rsp Int
_ = ByteString -> Response -> PushPromise
PushPromise ByteString
path Response
rsp