( Interaction(..)
, InteractionState(..)
, InteractionQueue
+ , ReceiveBodyRequest(..)
, newInteractionQueue
, newInteraction
- , defaultPageContentType
, setResponseStatus
)
where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.STM
-import Data.Ascii (Ascii)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
-import Data.Text (Text)
import Network.Socket
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
, itrLocalPort ∷ !PortNumber
, itrRemoteAddr ∷ !SockAddr
, itrRemoteCert ∷ !(Maybe X509)
- , itrResourcePath ∷ !(Maybe [Text])
+ , itrResourcePath ∷ !(Maybe [Strict.ByteString])
, itrRequest ∷ !(Maybe Request)
, itrExpectedContinue ∷ !(Maybe Bool)
, itrReqBodyLength ∷ !(Maybe RequestBodyLength)
- , itrReqBodyWanted ∷ !(TVar Int)
- , itrReqBodyWasteAll ∷ !(TVar Bool)
- , itrReqChunkIsOver ∷ !(TVar Bool)
- , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
- , itrReceivedBodyLen ∷ !(TVar Int)
+ , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , itrReceivedBody ∷ !(TMVar Strict.ByteString)
, itrResponse ∷ !(TVar Response)
, itrWillChunkBody ∷ !(TVar Bool)
, itrWillDiscardBody ∷ !(TVar Bool)
, itrWillClose ∷ !(TVar Bool)
+ , itrResponseHasCType ∷ !(TVar Bool)
, itrBodyToSend ∷ !(TMVar Builder)
- , itrSentNoBodySoFar ∷ !(TVar Bool)
, itrState ∷ !(TVar InteractionState)
}
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
-data InteractionState = ExaminingRequest
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord, Enum)
+data InteractionState
+ = ExaminingRequest
+ | ReceivingBody
+ | DecidingHeader
+ | SendingBody
+ | Done
+ deriving (Show, Eq, Ord, Enum)
type InteractionQueue = TVar (Seq Interaction)
+data ReceiveBodyRequest
+ = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+ | WasteAll
+ deriving (Show, Eq)
+
newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
-defaultPageContentType ∷ Ascii
-defaultPageContentType = "application/xhtml+xml"
-
newInteraction ∷ Config
→ PortNumber
→ SockAddr
res = Response {
resVersion = HttpVersion 1 1
, resStatus = arInitialStatus ar
- , resHeaders = singleton "Content-Type" defaultPageContentType
+ , resHeaders = (∅)
}
- reqBodyWanted ← newTVarIO 0
- reqBodyWasteAll ← newTVarIO False
- reqChunkIsOver ← newTVarIO False
- receivedBody ← newTVarIO S.empty
- receivedBodyLen ← newTVarIO 0
+ receiveBodyReq ← newEmptyTMVarIO
+ receivedBody ← newEmptyTMVarIO
- response ← newTVarIO res
- willChunkBody ← newTVarIO False
- willDiscardBody ← newTVarIO False
- willClose ← newTVarIO False
- bodyToSend ← newEmptyTMVarIO
- sentNoBodySoFar ← newTVarIO True
+ response ← newTVarIO res
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO (arWillDiscardBody ar)
+ willClose ← newTVarIO (arWillClose ar)
+ bodyToSend ← newEmptyTMVarIO
+ responseHasCType ← newTVarIO False
- state ← newTVarIO ExaminingRequest
+ state ← newTVarIO ExaminingRequest
return Interaction {
- itrConfig = conf
- , itrLocalPort = port
- , itrRemoteAddr = addr
- , itrRemoteCert = cert
- , itrResourcePath = Nothing
- , itrRequest = arRequest ar
+ itrConfig = conf
+ , itrLocalPort = port
+ , itrRemoteAddr = addr
+ , itrRemoteCert = cert
+ , itrResourcePath = Nothing
+ , itrRequest = arRequest ar
, itrExpectedContinue = arExpectedContinue ar
, itrReqBodyLength = arReqBodyLength ar
- , itrReqBodyWanted = reqBodyWanted
- , itrReqBodyWasteAll = reqBodyWasteAll
- , itrReqChunkIsOver = reqChunkIsOver
+ , itrReceiveBodyReq = receiveBodyReq
, itrReceivedBody = receivedBody
- , itrReceivedBodyLen = receivedBodyLen
, itrResponse = response
, itrWillChunkBody = willChunkBody
, itrWillDiscardBody = willDiscardBody
, itrWillClose = willClose
+ , itrResponseHasCType = responseHasCType
, itrBodyToSend = bodyToSend
- , itrSentNoBodySoFar = sentNoBodySoFar
, itrState = state
}