X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=f57a474f4884f388ecfe38be3f51e5edbba5a9ca;hp=638d1b05bafc472f364cfb7626930f6f00a86423;hb=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;hpb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 638d1b0..f57a474 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,183 +1,132 @@ {-# LANGUAGE - BangPatterns + OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue + , ReceiveBodyRequest(..) , newInteractionQueue , newInteraction - , defaultPageContentType - , writeItr - , readItr - , readItrF - , updateItr - , updateItrF + , setResponseStatus ) where - -import Control.Concurrent.STM -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) +import Blaze.ByteString.Builder (Builder) +import Control.Concurrent.STM +import qualified Data.ByteString as Strict +import Data.Monoid.Unicode +import Data.Sequence (Seq) import qualified Data.Sequence as S -import Data.Sequence (Seq) -import Network.Socket -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import OpenSSL.X509 +import Data.Text (Text) +import Network.Socket +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Preprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import OpenSSL.X509 data Interaction = Interaction { - itrConfig :: !Config - , itrLocalPort :: !PortNumber - , itrRemoteAddr :: !SockAddr - , itrRemoteCert :: !(Maybe X509) - , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し - , itrResponse :: !(TVar Response) - - , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し - - , itrReqChunkLength :: !(TVar (Maybe Int)) - , itrReqChunkRemaining :: !(TVar (Maybe Int)) - , itrReqChunkIsOver :: !(TVar Bool) - , itrReqBodyWanted :: !(TVar (Maybe Int)) - , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される - - , itrWillReceiveBody :: !(TVar Bool) - , itrWillChunkBody :: !(TVar Bool) - , itrWillDiscardBody :: !(TVar Bool) - , itrWillClose :: !(TVar Bool) - - , itrBodyToSend :: !(TVar Lazy.ByteString) - , itrBodyIsNull :: !(TVar Bool) - - , itrState :: !(TVar InteractionState) - - , itrWroteContinue :: !(TVar Bool) - , itrWroteHeader :: !(TVar Bool) + itrConfig ∷ !Config + , itrLocalPort ∷ !PortNumber + , itrRemoteAddr ∷ !SockAddr + , itrRemoteCert ∷ !(Maybe X509) + , itrResourcePath ∷ !(Maybe [Text]) + , itrRequest ∷ !(Maybe Request) + + , itrExpectedContinue ∷ !(Maybe Bool) + , itrReqBodyLength ∷ !(Maybe RequestBodyLength) + + , 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) + + , itrState ∷ !(TVar InteractionState) } --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingRequest。 -data InteractionState = ExaminingRequest - | GettingBody - | DecidingHeader - | DecidingBody - | Done - deriving (Show, Eq, Ord, Enum) +-- |The interaction state of Resource monad. 'ExaminingRequest' is the +-- initial state. +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 ∷ IO InteractionQueue newInteractionQueue = newTVarIO S.empty - -defaultPageContentType :: Strict.ByteString -defaultPageContentType = C8.pack "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 [(C8.pack "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 L8.empty - - willReceiveBody <- newTVarIO False - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - - bodyToSend <- newTVarIO L8.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 + + 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 + + , 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 () -writeItr !itr !accessor !value - = writeTVar (accessor itr) value - - -readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr !itr !accessor !reader - = fmap reader $ readTVar (accessor itr) - - -readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) -readItrF !itr !accessor !reader - = readItr itr accessor (fmap reader) -{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} - - -updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () -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 () -updateItrF !itr !accessor !updator - = updateItr itr accessor (fmap updator) -{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file +setResponseStatus ∷ Interaction → StatusCode → STM () +setResponseStatus (Interaction {..}) sc + = do res ← readTVar itrResponse + let res' = res { + resStatus = sc + } + writeTVar itrResponse res'