X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=20b4bc27ec956fffb6b959be6dae9c6359182694;hb=8225cc52ffe4c3d900ae1f79573089be230b80bd;hp=19faec28fe7a1fb506f42d5416123f17ec52a61d;hpb=e34910f85f459f049b9e6e6b79db9ef95dfccc13;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 19faec2..20b4bc2 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,178 +1,134 @@ {-# LANGUAGE - BangPatterns - , OverloadedStrings + OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue + , ReceiveBodyRequest(..) , newInteractionQueue , newInteraction - , defaultPageContentType - , writeItr - , readItr - , readItrF - , updateItr - , updateItrF + , setResponseStatus ) where -import Control.Applicative +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 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 import Network.HTTP.Lucu.Response import OpenSSL.X509 -import Prelude.Unicode data Interaction = Interaction { itrConfig ∷ !Config , itrLocalPort ∷ !PortNumber , itrRemoteAddr ∷ !SockAddr , itrRemoteCert ∷ !(Maybe X509) - , itrResourcePath ∷ !(Maybe [Ascii]) - , itrRequest ∷ !(TVar (Maybe Request)) - , itrResponse ∷ !(TVar Response) + , itrResourcePath ∷ !(Maybe [Strict.ByteString]) + , itrRequest ∷ !(Maybe Request) - , itrRequestHasBody ∷ !(TVar Bool) - , itrRequestIsChunked ∷ !(TVar Bool) - , itrExpectedContinue ∷ !(TVar Bool) + , itrExpectedContinue ∷ !(Maybe Bool) + , itrReqBodyLength ∷ !(Maybe RequestBodyLength) - , itrReqChunkLength ∷ !(TVar (Maybe Int)) - , itrReqChunkRemaining ∷ !(TVar (Maybe Int)) - , itrReqChunkIsOver ∷ !(TVar Bool) - , itrReqBodyWanted ∷ !(TVar (Maybe Int)) - , itrReqBodyWasteAll ∷ !(TVar Bool) - , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) + , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) + , itrReceivedBody ∷ !(TMVar Strict.ByteString) - , itrWillReceiveBody ∷ !(TVar Bool) + , itrSendContinue ∷ !(TMVar Bool) + , itrResponse ∷ !(TVar Response) , itrWillChunkBody ∷ !(TVar Bool) , itrWillDiscardBody ∷ !(TVar Bool) , itrWillClose ∷ !(TVar Bool) - - , itrBodyToSend ∷ !(TVar (Seq BS.ByteString)) - , itrBodyIsNull ∷ !(TVar Bool) + , itrResponseHasCType ∷ !(TVar Bool) + , itrBodyToSend ∷ !(TMVar Builder) , itrState ∷ !(TVar InteractionState) - - , itrWroteContinue ∷ !(TVar Bool) - , itrWroteHeader ∷ !(TVar Bool) } -- |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 → Maybe X509 → Maybe Request → IO Interaction -newInteraction !conf !port !addr !cert !req - = do request ← newTVarIO req - responce ← newTVarIO Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = toHeaders [("Content-Type", defaultPageContentType)] - } - - requestHasBody ← newTVarIO False - requestIsChunked ← newTVarIO False - expectedContinue ← newTVarIO False - - reqChunkLength ← newTVarIO Nothing -- 現在のチャンク長 - reqChunkRemaining ← newTVarIO Nothing -- 現在のチャンクの殘り - reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた - reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長 - reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - receivedBody ← newTVarIO S.empty - - willReceiveBody ← newTVarIO False - willChunkBody ← newTVarIO False - willDiscardBody ← newTVarIO False - willClose ← newTVarIO False - - bodyToSend ← newTVarIO S.empty - bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - - state ← newTVarIO ExaminingRequest - - wroteContinue ← newTVarIO False - wroteHeader ← newTVarIO False +newInteraction ∷ Config + → PortNumber + → SockAddr + → Maybe X509 + → Either StatusCode Request + → IO Interaction +newInteraction conf@(Config {..}) port addr cert request + = do let ar = preprocess cnfServerHost port request + res = Response { + resVersion = HttpVersion 1 1 + , resStatus = arInitialStatus ar + , resHeaders = (∅) + } + + receiveBodyReq ← newEmptyTMVarIO + receivedBody ← newEmptyTMVarIO + + sendContinue ← newEmptyTMVarIO + response ← newTVarIO res + willChunkBody ← newTVarIO False + willDiscardBody ← newTVarIO (arWillDiscardBody ar) + willClose ← newTVarIO (arWillClose ar) + bodyToSend ← newEmptyTMVarIO + responseHasCType ← newTVarIO False + + state ← newTVarIO ExaminingRequest return Interaction { - itrConfig = conf - , itrLocalPort = port - , itrRemoteAddr = addr - , itrRemoteCert = cert - , itrResourcePath = Nothing - , itrRequest = request - , itrResponse = responce - - , itrRequestHasBody = requestHasBody - , itrRequestIsChunked = requestIsChunked - , itrExpectedContinue = expectedContinue - - , itrReqChunkLength = reqChunkLength - , itrReqChunkRemaining = reqChunkRemaining - , itrReqChunkIsOver = reqChunkIsOver - , itrReqBodyWanted = reqBodyWanted - , itrReqBodyWasteAll = reqBodyWasteAll - , itrReceivedBody = receivedBody - - , itrWillReceiveBody = willReceiveBody - , itrWillChunkBody = willChunkBody - , itrWillDiscardBody = willDiscardBody - , itrWillClose = willClose - - , itrBodyToSend = bodyToSend - , itrBodyIsNull = bodyIsNull - - , itrState = state + itrConfig = conf + , itrLocalPort = port + , itrRemoteAddr = addr + , itrRemoteCert = cert + , itrResourcePath = Nothing + , itrRequest = arRequest ar + + , itrExpectedContinue = arExpectedContinue ar + , itrReqBodyLength = arReqBodyLength ar + + , itrReceiveBodyReq = receiveBodyReq + , itrReceivedBody = receivedBody + + , itrSendContinue = sendContinue + , itrResponse = response + , itrWillChunkBody = willChunkBody + , itrWillDiscardBody = willDiscardBody + , itrWillClose = willClose + , itrResponseHasCType = responseHasCType + , itrBodyToSend = bodyToSend - , itrWroteContinue = wroteContinue - , itrWroteHeader = wroteHeader + , itrState = state } -writeItr ∷ Interaction → (Interaction → TVar a) → a → STM () -{-# INLINE writeItr #-} -writeItr itr accessor - = writeTVar (accessor itr) - -readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b -{-# INLINE readItr #-} -readItr itr accessor reader - = reader <$> readTVar (accessor itr) - -readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b) -{-# INLINE readItrF #-} -readItrF itr accessor reader - = readItr itr accessor (fmap reader) - -updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM () -{-# INLINE updateItr #-} -updateItr itr accessor updator - = do old ← readItr itr accessor id - writeItr itr accessor (updator old) - -updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM () -{-# INLINE updateItrF #-} -updateItrF itr accessor - = updateItr itr accessor ∘ fmap +setResponseStatus ∷ Interaction → StatusCode → STM () +setResponseStatus (Interaction {..}) sc + = do res ← readTVar itrResponse + let res' = res { + resStatus = sc + } + writeTVar itrResponse res'