2 module Network.HTTP.Lucu.Interaction
8 , defaultPageContentType
18 import Control.Concurrent.STM
19 import qualified Data.ByteString.Lazy.Char8 as B
20 import Data.ByteString.Lazy.Char8 (ByteString)
21 import qualified Data.Sequence as S
22 import Data.Sequence (Seq)
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.HttpVersion
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
29 data Interaction = Interaction {
31 , itrRemoteAddr :: !SockAddr
32 , itrResourcePath :: !(Maybe [String])
33 , itrRequest :: !(TVar (Maybe Request))
34 , itrResponse :: !(TVar Response)
36 -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
37 -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
38 -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
40 , itrRequestHasBody :: !(TVar Bool)
41 , itrRequestIsChunked :: !(TVar Bool)
42 , itrExpectedContinue :: !(TVar Bool)
44 , itrReqChunkLength :: !(TVar (Maybe Int))
45 , itrReqChunkRemaining :: !(TVar (Maybe Int))
46 , itrReqChunkIsOver :: !(TVar Bool)
47 , itrReqBodyWanted :: !(TVar (Maybe Int))
48 , itrReqBodyWasteAll :: !(TVar Bool)
49 , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される
51 , itrWillReceiveBody :: !(TVar Bool)
52 , itrWillChunkBody :: !(TVar Bool)
53 , itrWillDiscardBody :: !(TVar Bool)
54 , itrWillClose :: !(TVar Bool)
56 , itrBodyToSend :: !(TVar ByteString)
57 , itrBodyIsNull :: !(TVar Bool)
59 , itrState :: !(TVar InteractionState)
61 , itrWroteContinue :: !(TVar Bool)
62 , itrWroteHeader :: !(TVar Bool)
65 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
66 -- 状態は ExaminingRequest。
67 data InteractionState = ExaminingRequest
72 deriving (Show, Eq, Ord, Enum)
74 type InteractionQueue = TVar (Seq Interaction)
77 newInteractionQueue :: IO InteractionQueue
78 newInteractionQueue = newTVarIO S.empty
81 defaultPageContentType :: String
82 defaultPageContentType = "application/xhtml+xml"
85 newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
86 newInteraction conf addr req
87 = conf `seq` addr `seq` req `seq`
88 do request <- newTVarIO $ req
89 responce <- newTVarIO $ Response {
90 resVersion = HttpVersion 1 1
92 , resHeaders = [("Content-Type", defaultPageContentType)]
95 requestHasBody <- newTVarIO False
96 requestIsChunked <- newTVarIO False
97 expectedContinue <- newTVarIO False
99 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
100 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
101 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
102 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
103 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
104 receivedBody <- newTVarIO B.empty
106 willReceiveBody <- newTVarIO False
107 willChunkBody <- newTVarIO False
108 willDiscardBody <- newTVarIO False
109 willClose <- newTVarIO False
111 bodyToSend <- newTVarIO B.empty
112 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
114 state <- newTVarIO ExaminingRequest
116 wroteContinue <- newTVarIO False
117 wroteHeader <- newTVarIO False
119 return $ Interaction {
121 , itrRemoteAddr = addr
122 , itrResourcePath = Nothing
123 , itrRequest = request
124 , itrResponse = responce
126 , itrRequestHasBody = requestHasBody
127 , itrRequestIsChunked = requestIsChunked
128 , itrExpectedContinue = expectedContinue
130 , itrReqChunkLength = reqChunkLength
131 , itrReqChunkRemaining = reqChunkRemaining
132 , itrReqChunkIsOver = reqChunkIsOver
133 , itrReqBodyWanted = reqBodyWanted
134 , itrReqBodyWasteAll = reqBodyWasteAll
135 , itrReceivedBody = receivedBody
137 , itrWillReceiveBody = willReceiveBody
138 , itrWillChunkBody = willChunkBody
139 , itrWillDiscardBody = willDiscardBody
140 , itrWillClose = willClose
142 , itrBodyToSend = bodyToSend
143 , itrBodyIsNull = bodyIsNull
147 , itrWroteContinue = wroteContinue
148 , itrWroteHeader = wroteHeader
152 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
153 writeItr itr accessor value
154 = itr `seq` accessor `seq` value `seq`
155 writeTVar (accessor itr) value
158 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
159 readItr itr accessor reader
160 = itr `seq` accessor `seq` reader `seq`
161 readTVar (accessor itr) >>= return . reader
164 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
165 readItrF itr accessor reader
166 = itr `seq` accessor `seq` reader `seq`
167 readItr itr accessor (fmap reader)
168 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
171 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
172 updateItr itr accessor updator
173 = itr `seq` accessor `seq` updator `seq`
174 do old <- readItr itr accessor id
175 writeItr itr accessor (updator old)
178 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
179 updateItrF itr accessor updator
180 = itr `seq` accessor `seq` updator `seq`
181 updateItr itr accessor (fmap updator)
182 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}