X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=ac5c1d6285aa33d936d4ae23135cb09b4ef8e125;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=5f28c558c9b53f3c53d79196fd576b54da373ce4;hpb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 5f28c55..ac5c1d6 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,61 +1,64 @@ +{-# LANGUAGE + OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue - , newInteractionQueue -- IO InteractionQueue - , newInteraction -- Config -> 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 + + , setResponseStatus ) where - -import Control.Concurrent.STM -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Blaze.ByteString.Builder (Builder) +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.Config -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response +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 +import Network.HTTP.Lucu.Response +import OpenSSL.X509 data Interaction = Interaction { - itrConfig :: Config - , itrRemoteHost :: HostName - , itrRequest :: Maybe Request - , itrResponse :: TVar (Maybe 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 ByteString -- Resource が受領した部分は削除される - - , itrWillReceiveBody :: TVar Bool - , itrWillChunkBody :: TVar Bool - , itrWillDiscardBody :: TVar Bool - , itrWillClose :: TVar Bool - - , itrBodyToSend :: TVar 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) + + , itrReqBodyWanted ∷ !(TVar Int) + , itrReqBodyWasteAll ∷ !(TVar Bool) + , itrReqChunkIsOver ∷ !(TVar Bool) + , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) + , itrReceivedBodyLen ∷ !(TVar Int) + + , itrResponse ∷ !(TVar Response) + , itrWillChunkBody ∷ !(TVar Bool) + , itrWillDiscardBody ∷ !(TVar Bool) + , itrWillClose ∷ !(TVar Bool) + , itrBodyToSend ∷ !(TMVar Builder) + , itrSentNoBodySoFar ∷ !(TVar Bool) + + , itrState ∷ !(TVar InteractionState) } --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingRequest。 +-- |The interaction state of Resource monad. 'ExaminingRequest' is the +-- initial state. data InteractionState = ExaminingRequest | GettingBody | DecidingHeader @@ -65,92 +68,72 @@ data InteractionState = ExaminingRequest type InteractionQueue = TVar (Seq Interaction) - -newInteractionQueue :: IO InteractionQueue +newInteractionQueue ∷ IO InteractionQueue newInteractionQueue = newTVarIO S.empty - -newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction -newInteraction conf host req - = do responce <- newTVarIO Nothing - - 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 B.empty - - willReceiveBody <- newTVarIO False - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - - bodyToSend <- newTVarIO B.empty - bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - - state <- newTVarIO ExaminingRequest - - wroteContinue <- newTVarIO False - wroteHeader <- newTVarIO False - - return $ Interaction { - itrConfig = conf - , itrRemoteHost = host - , itrRequest = req - , 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 +defaultPageContentType ∷ Ascii +defaultPageContentType = "application/xhtml+xml" + +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 = singleton "Content-Type" defaultPageContentType + } + + reqBodyWanted ← newTVarIO 0 + reqBodyWasteAll ← newTVarIO False + reqChunkIsOver ← newTVarIO False + receivedBody ← newTVarIO S.empty + receivedBodyLen ← newTVarIO 0 + + response ← newTVarIO res + willChunkBody ← newTVarIO False + willDiscardBody ← newTVarIO False + willClose ← newTVarIO False + bodyToSend ← newEmptyTMVarIO + sentNoBodySoFar ← newTVarIO True + + state ← newTVarIO ExaminingRequest + + return Interaction { + 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 + , itrReceivedBody = receivedBody + , itrReceivedBodyLen = receivedBodyLen + + , itrResponse = response + , itrWillChunkBody = willChunkBody + , itrWillDiscardBody = willDiscardBody + , itrWillClose = willClose + , itrBodyToSend = bodyToSend + , itrSentNoBodySoFar = sentNoBodySoFar - , itrState = state - - , 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 - = readTVar (accessor itr) >>= return . reader - - -readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) -readItrF itr accessor reader - = readItr itr accessor (fmap reader) - - -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) +setResponseStatus ∷ Interaction → StatusCode → STM () +setResponseStatus (Interaction {..}) sc + = do res ← readTVar itrResponse + let res' = res { + resStatus = sc + } + writeTVar itrResponse res'