X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=19faec28fe7a1fb506f42d5416123f17ec52a61d;hb=c7a8bc012b1b70353d567bfab86fc6e849d60c20;hp=44f4243b6ebe2abb5b02cb0891d783bd60f60655;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 44f4243..19faec2 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,101 +1,178 @@ +{-# LANGUAGE + BangPatterns + , OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue - , newInteractionQueue -- IO InteractionQueue - , newInteraction -- HostName -> Maybe Request -> IO Interaction + , newInteractionQueue + , newInteraction + , defaultPageContentType + + , writeItr + , readItr + , readItrF + , updateItr + , updateItrF ) where - -import Control.Concurrent.STM -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Control.Applicative +import Control.Concurrent.STM +import Data.Ascii (Ascii) +import qualified Data.ByteString as BS +import Data.Sequence (Seq) import qualified Data.Sequence as S -import Data.Sequence (Seq) -import Network -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response +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 Prelude.Unicode data Interaction = Interaction { - itrRemoteHost :: HostName - , itrRequest :: Maybe Request - , itrResponse :: TVar (Maybe Response) - - , itrRequestHasBody :: TVar Bool - , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明 - , itrRequestIsChunked :: TVar Bool - , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される - - , itrExpectedContinue :: TVar Bool - - , itrWillChunkBody :: TVar Bool - , itrWillDiscardBody :: TVar Bool - , itrWillClose :: TVar Bool - , itrBodyToSend :: TVar ByteString - - , itrState :: TVar InteractionState - - , itrWroteContinue :: TVar Bool - , itrWroteHeader :: TVar Bool + itrConfig ∷ !Config + , itrLocalPort ∷ !PortNumber + , itrRemoteAddr ∷ !SockAddr + , itrRemoteCert ∷ !(Maybe X509) + , itrResourcePath ∷ !(Maybe [Ascii]) + , itrRequest ∷ !(TVar (Maybe Request)) + , itrResponse ∷ !(TVar Response) + + , itrRequestHasBody ∷ !(TVar Bool) + , itrRequestIsChunked ∷ !(TVar Bool) + , itrExpectedContinue ∷ !(TVar Bool) + + , itrReqChunkLength ∷ !(TVar (Maybe Int)) + , itrReqChunkRemaining ∷ !(TVar (Maybe Int)) + , itrReqChunkIsOver ∷ !(TVar Bool) + , itrReqBodyWanted ∷ !(TVar (Maybe Int)) + , itrReqBodyWasteAll ∷ !(TVar Bool) + , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) + + , itrWillReceiveBody ∷ !(TVar Bool) + , itrWillChunkBody ∷ !(TVar Bool) + , itrWillDiscardBody ∷ !(TVar Bool) + , itrWillClose ∷ !(TVar Bool) + + , itrBodyToSend ∷ !(TVar (Seq BS.ByteString)) + , itrBodyIsNull ∷ !(TVar Bool) + + , itrState ∷ !(TVar InteractionState) + + , itrWroteContinue ∷ !(TVar Bool) + , itrWroteHeader ∷ !(TVar Bool) } --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingHeader (リクエストボディが有る時) または --- DecidingHeader (無い時)。終了状態は常に Done -data InteractionState = ExaminingHeader +-- |The interaction state of Resource monad. 'ExaminingRequest' is the +-- initial state. +data InteractionState = ExaminingRequest | GettingBody | DecidingHeader | DecidingBody | Done - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Enum) type InteractionQueue = TVar (Seq Interaction) - -newInteractionQueue :: IO InteractionQueue +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 + + return Interaction { + itrConfig = conf + , itrLocalPort = port + , itrRemoteAddr = addr + , itrRemoteCert = cert + , itrResourcePath = Nothing + , itrRequest = request + , itrResponse = responce + + , itrRequestHasBody = requestHasBody + , itrRequestIsChunked = requestIsChunked + , itrExpectedContinue = expectedContinue -newInteraction :: HostName -> Maybe Request -> IO Interaction -newInteraction host req - = do responce <- newTVarIO Nothing - - requestHasBody <- newTVarIO False - requestBodyLength <- newTVarIO Nothing - requestIsChunked <- newTVarIO False - receivedBody <- newTVarIO B.empty - - expectedContinue <- newTVarIO False - - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - bodyToSend <- newTVarIO B.empty - - state <- newTVarIO undefined - - wroteContinue <- newTVarIO False - wroteHeader <- newTVarIO False - - return $ Interaction { - itrRemoteHost = host - , itrRequest = req - , itrResponse = responce - - , itrRequestHasBody = requestHasBody - , itrRequestBodyLength = requestBodyLength - , itrRequestIsChunked = requestIsChunked + , itrReqChunkLength = reqChunkLength + , itrReqChunkRemaining = reqChunkRemaining + , itrReqChunkIsOver = reqChunkIsOver + , itrReqBodyWanted = reqBodyWanted + , itrReqBodyWasteAll = reqBodyWasteAll , itrReceivedBody = receivedBody - , itrExpectedContinue = expectedContinue + , itrWillReceiveBody = willReceiveBody + , itrWillChunkBody = willChunkBody + , itrWillDiscardBody = willDiscardBody + , itrWillClose = willClose - , itrWillChunkBody = willChunkBody - , itrWillDiscardBody = willDiscardBody - , itrWillClose = willClose - , itrBodyToSend = bodyToSend + , itrBodyToSend = bodyToSend + , itrBodyIsNull = bodyIsNull , itrState = state , itrWroteContinue = wroteContinue , itrWroteHeader = wroteHeader } + +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