X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=638d1b05bafc472f364cfb7626930f6f00a86423;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=6b872ca5ff24a38ab16b74fb32d4df7d40e06abd;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6b872ca..638d1b0 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,59 +1,80 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue - , newInteractionQueue -- IO InteractionQueue - , newInteraction -- HostName -> Maybe Request -> IO Interaction - - , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM () - , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b - , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) - , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () - , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () + , 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 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 qualified Data.Sequence as S import Data.Sequence (Seq) -import Network +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 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 [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) } -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingHeader (リクエストボディが有る時) または --- DecidingHeader (無い時)。終了状態は常に Done -data InteractionState = ExaminingHeader +-- 状態は ExaminingRequest。 +data InteractionState = ExaminingRequest | GettingBody | DecidingHeader | DecidingBody | Done - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Enum) type InteractionQueue = TVar (Seq Interaction) @@ -62,43 +83,70 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty -newInteraction :: HostName -> Maybe Request -> IO Interaction -newInteraction host req - = do responce <- newTVarIO Nothing +defaultPageContentType :: Strict.ByteString +defaultPageContentType = C8.pack "application/xhtml+xml" - requestHasBody <- newTVarIO False - requestBodyLength <- newTVarIO Nothing - requestIsChunked <- newTVarIO False - receivedBody <- newTVarIO B.empty - expectedContinue <- newTVarIO False +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)] + } - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - bodyToSend <- newTVarIO B.empty + 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 - state <- newTVarIO undefined + 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 - return $ Interaction { - itrRemoteHost = host - , itrRequest = req - , itrResponse = responce + return Interaction { + itrConfig = conf + , itrLocalPort = port + , itrRemoteAddr = addr + , itrRemoteCert = cert + , itrResourcePath = Nothing + , itrRequest = request + , itrResponse = responce + + , itrRequestHasBody = requestHasBody + , itrRequestIsChunked = requestIsChunked + , itrExpectedContinue = expectedContinue - , 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 @@ -108,26 +156,28 @@ newInteraction host req writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () -writeItr itr accessor value +writeItr !itr !accessor !value = writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr itr accessor reader - = readTVar (accessor itr) >>= return . reader +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 +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 +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 +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