( Interaction(..)
, InteractionState(..)
, InteractionQueue
- , newInteractionQueue -- IO InteractionQueue
- , newInteraction -- HostName -> Maybe Request -> IO Interaction
+ , newInteractionQueue
+ , newInteraction
+ , defaultPageContentType
+
+ , writeItr
+ , readItr
+ , readItrF
+ , updateItr
+ , updateItrF
)
where
import Data.ByteString.Lazy.Char8 (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.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
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
+ , itrRemoteAddr :: !SockAddr
+ , itrResourcePath :: !(Maybe [String])
+ , itrRequest :: !(TVar (Maybe Request))
+ , itrResponse :: !(TVar Response)
+
+ -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
+ -- るに越した事は無いが、それは重要でない。
+ , 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)
}
-- 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)
newInteractionQueue = newTVarIO S.empty
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
- = do responce <- newTVarIO Nothing
+defaultPageContentType :: String
+defaultPageContentType = "application/xhtml+xml"
- requestHasBody <- newTVarIO False
- requestBodyLength <- newTVarIO Nothing
- requestIsChunked <- newTVarIO False
- receivedBody <- newTVarIO B.empty
- expectedContinue <- newTVarIO False
+newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
+newInteraction conf addr req
+ = conf `seq` addr `seq` req `seq`
+ do request <- newTVarIO $ req
+ responce <- newTVarIO $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Ok
+ , resHeaders = [("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 B.empty
- state <- newTVarIO undefined
+ 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 {
- itrRemoteHost = host
- , itrRequest = req
- , itrResponse = responce
+ itrConfig = conf
+ , itrRemoteAddr = addr
+ , itrResourcePath = Nothing
+ , itrRequest = request
+ , itrResponse = responce
, itrRequestHasBody = requestHasBody
- , itrRequestBodyLength = requestBodyLength
, itrRequestIsChunked = requestIsChunked
+ , itrExpectedContinue = expectedContinue
+
+ , 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 ()
+writeItr itr accessor value
+ = itr `seq` accessor `seq` value `seq`
+ writeTVar (accessor itr) value
+
+
+readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
+readItr itr accessor reader
+ = itr `seq` accessor `seq` reader `seq`
+ readTVar (accessor itr) >>= return . reader
+
+
+readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF itr accessor reader
+ = itr `seq` accessor `seq` reader `seq`
+ 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
+ = itr `seq` accessor `seq` updator `seq`
+ 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
+ = itr `seq` accessor `seq` updator `seq`
+ updateItr itr accessor (fmap updator)
+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file