1 module Network.HTTP.Lucu.Interaction
7 , defaultPageContentType
17 import Control.Concurrent.STM
18 import qualified Data.ByteString as Strict (ByteString)
19 import qualified Data.ByteString.Lazy as Lazy (ByteString)
20 import Data.ByteString.Char8 as C8 hiding (ByteString)
21 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
22 import qualified Data.Sequence as S
23 import Data.Sequence (Seq)
25 import Network.HTTP.Lucu.Config
26 import Network.HTTP.Lucu.Headers
27 import Network.HTTP.Lucu.HttpVersion
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response
31 data Interaction = Interaction {
33 , itrRemoteAddr :: !SockAddr
34 , itrResourcePath :: !(Maybe [String])
35 , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
36 , itrResponse :: !(TVar Response)
38 , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し
39 , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し
40 , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し
42 , itrReqChunkLength :: !(TVar (Maybe Int))
43 , itrReqChunkRemaining :: !(TVar (Maybe Int))
44 , itrReqChunkIsOver :: !(TVar Bool)
45 , itrReqBodyWanted :: !(TVar (Maybe Int))
46 , itrReqBodyWasteAll :: !(TVar Bool)
47 , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
49 , itrWillReceiveBody :: !(TVar Bool)
50 , itrWillChunkBody :: !(TVar Bool)
51 , itrWillDiscardBody :: !(TVar Bool)
52 , itrWillClose :: !(TVar Bool)
54 , itrBodyToSend :: !(TVar Lazy.ByteString)
55 , itrBodyIsNull :: !(TVar Bool)
57 , itrState :: !(TVar InteractionState)
59 , itrWroteContinue :: !(TVar Bool)
60 , itrWroteHeader :: !(TVar Bool)
63 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
64 -- 状態は ExaminingRequest。
65 data InteractionState = ExaminingRequest
70 deriving (Show, Eq, Ord, Enum)
72 type InteractionQueue = TVar (Seq Interaction)
75 newInteractionQueue :: IO InteractionQueue
76 newInteractionQueue = newTVarIO S.empty
79 defaultPageContentType :: Strict.ByteString
80 defaultPageContentType = C8.pack "application/xhtml+xml"
83 newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
84 newInteraction conf addr req
85 = conf `seq` addr `seq` req `seq`
86 do request <- newTVarIO $ req
87 responce <- newTVarIO $ Response {
88 resVersion = HttpVersion 1 1
90 , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
93 requestHasBody <- newTVarIO False
94 requestIsChunked <- newTVarIO False
95 expectedContinue <- newTVarIO False
97 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
98 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
99 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
100 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
101 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
102 receivedBody <- newTVarIO L8.empty
104 willReceiveBody <- newTVarIO False
105 willChunkBody <- newTVarIO False
106 willDiscardBody <- newTVarIO False
107 willClose <- newTVarIO False
109 bodyToSend <- newTVarIO L8.empty
110 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
112 state <- newTVarIO ExaminingRequest
114 wroteContinue <- newTVarIO False
115 wroteHeader <- newTVarIO False
117 return $ Interaction {
119 , itrRemoteAddr = addr
120 , itrResourcePath = Nothing
121 , itrRequest = request
122 , itrResponse = responce
124 , itrRequestHasBody = requestHasBody
125 , itrRequestIsChunked = requestIsChunked
126 , itrExpectedContinue = expectedContinue
128 , itrReqChunkLength = reqChunkLength
129 , itrReqChunkRemaining = reqChunkRemaining
130 , itrReqChunkIsOver = reqChunkIsOver
131 , itrReqBodyWanted = reqBodyWanted
132 , itrReqBodyWasteAll = reqBodyWasteAll
133 , itrReceivedBody = receivedBody
135 , itrWillReceiveBody = willReceiveBody
136 , itrWillChunkBody = willChunkBody
137 , itrWillDiscardBody = willDiscardBody
138 , itrWillClose = willClose
140 , itrBodyToSend = bodyToSend
141 , itrBodyIsNull = bodyIsNull
145 , itrWroteContinue = wroteContinue
146 , itrWroteHeader = wroteHeader
150 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
151 writeItr itr accessor value
152 = itr `seq` accessor `seq` value `seq`
153 writeTVar (accessor itr) value
156 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
157 readItr itr accessor reader
158 = itr `seq` accessor `seq` reader `seq`
159 readTVar (accessor itr) >>= return . reader
162 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
163 readItrF itr accessor reader
164 = itr `seq` accessor `seq` reader `seq`
165 readItr itr accessor (fmap reader)
166 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
169 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
170 updateItr itr accessor updator
171 = itr `seq` accessor `seq` updator `seq`
172 do old <- readItr itr accessor id
173 writeItr itr accessor (updator old)
176 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
177 updateItrF itr accessor updator
178 = itr `seq` accessor `seq` updator `seq`
179 updateItr itr accessor (fmap updator)
180 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}