1 module Network.HTTP.Lucu.Interaction
7 , defaultPageContentType
17 import Control.Concurrent.STM
18 import qualified Data.ByteString.Lazy.Char8 as B
19 import Data.ByteString.Lazy.Char8 (ByteString)
20 import qualified Data.Sequence as S
21 import Data.Sequence (Seq)
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.HttpVersion
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
28 data Interaction = Interaction {
30 , itrRemoteAddr :: !SockAddr
31 , itrResourcePath :: !(Maybe [String])
32 , itrRequest :: !(TVar (Maybe Request))
33 , itrResponse :: !(TVar Response)
35 -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
36 -- るに越した事は無いが、それは重要でない。
37 , itrRequestHasBody :: !(TVar Bool)
38 , itrRequestIsChunked :: !(TVar Bool)
39 , itrExpectedContinue :: !(TVar Bool)
41 , itrReqChunkLength :: !(TVar (Maybe Int))
42 , itrReqChunkRemaining :: !(TVar (Maybe Int))
43 , itrReqChunkIsOver :: !(TVar Bool)
44 , itrReqBodyWanted :: !(TVar (Maybe Int))
45 , itrReqBodyWasteAll :: !(TVar Bool)
46 , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される
48 , itrWillReceiveBody :: !(TVar Bool)
49 , itrWillChunkBody :: !(TVar Bool)
50 , itrWillDiscardBody :: !(TVar Bool)
51 , itrWillClose :: !(TVar Bool)
53 , itrBodyToSend :: !(TVar ByteString)
54 , itrBodyIsNull :: !(TVar Bool)
56 , itrState :: !(TVar InteractionState)
58 , itrWroteContinue :: !(TVar Bool)
59 , itrWroteHeader :: !(TVar Bool)
62 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
63 -- 状態は ExaminingRequest。
64 data InteractionState = ExaminingRequest
69 deriving (Show, Eq, Ord, Enum)
71 type InteractionQueue = TVar (Seq Interaction)
74 newInteractionQueue :: IO InteractionQueue
75 newInteractionQueue = newTVarIO S.empty
78 defaultPageContentType :: String
79 defaultPageContentType = "application/xhtml+xml"
82 newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
83 newInteraction conf addr req
84 = conf `seq` addr `seq` req `seq`
85 do request <- newTVarIO $ req
86 responce <- newTVarIO $ Response {
87 resVersion = HttpVersion 1 1
89 , resHeaders = [("Content-Type", defaultPageContentType)]
92 requestHasBody <- newTVarIO False
93 requestIsChunked <- newTVarIO False
94 expectedContinue <- newTVarIO False
96 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
97 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
98 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
99 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
100 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
101 receivedBody <- newTVarIO B.empty
103 willReceiveBody <- newTVarIO False
104 willChunkBody <- newTVarIO False
105 willDiscardBody <- newTVarIO False
106 willClose <- newTVarIO False
108 bodyToSend <- newTVarIO B.empty
109 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
111 state <- newTVarIO ExaminingRequest
113 wroteContinue <- newTVarIO False
114 wroteHeader <- newTVarIO False
116 return $ Interaction {
118 , itrRemoteAddr = addr
119 , itrResourcePath = Nothing
120 , itrRequest = request
121 , itrResponse = responce
123 , itrRequestHasBody = requestHasBody
124 , itrRequestIsChunked = requestIsChunked
125 , itrExpectedContinue = expectedContinue
127 , itrReqChunkLength = reqChunkLength
128 , itrReqChunkRemaining = reqChunkRemaining
129 , itrReqChunkIsOver = reqChunkIsOver
130 , itrReqBodyWanted = reqBodyWanted
131 , itrReqBodyWasteAll = reqBodyWasteAll
132 , itrReceivedBody = receivedBody
134 , itrWillReceiveBody = willReceiveBody
135 , itrWillChunkBody = willChunkBody
136 , itrWillDiscardBody = willDiscardBody
137 , itrWillClose = willClose
139 , itrBodyToSend = bodyToSend
140 , itrBodyIsNull = bodyIsNull
144 , itrWroteContinue = wroteContinue
145 , itrWroteHeader = wroteHeader
149 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
150 writeItr itr accessor value
151 = itr `seq` accessor `seq` value `seq`
152 writeTVar (accessor itr) value
155 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
156 readItr itr accessor reader
157 = itr `seq` accessor `seq` reader `seq`
158 readTVar (accessor itr) >>= return . reader
161 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
162 readItrF itr accessor reader
163 = itr `seq` accessor `seq` reader `seq`
164 readItr itr accessor (fmap reader)
165 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
168 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
169 updateItr itr accessor updator
170 = itr `seq` accessor `seq` updator `seq`
171 do old <- readItr itr accessor id
172 writeItr itr accessor (updator old)
175 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
176 updateItrF itr accessor updator
177 = itr `seq` accessor `seq` updator `seq`
178 updateItr itr accessor (fmap updator)
179 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}