X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=86b6dbd4fb85293071f2328eec6c5eab8ac090fd;hb=7bc27fc4e86df6cb4d269b42252de735247f8c57;hp=ac5c1d6285aa33d936d4ae23135cb09b4ef8e125;hpb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index ac5c1d6..86b6dbd 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -7,23 +7,21 @@ module Network.HTTP.Lucu.Interaction ( 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 @@ -35,45 +33,45 @@ data Interaction = Interaction { , 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 @@ -85,47 +83,41 @@ newInteraction conf@(Config {..}) port addr cert request 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 }