1 module Network.HTTP.Lucu.Interaction
7 , defaultPageContentType
17 import Control.Concurrent.STM
18 import Data.ByteString.Base (ByteString, LazyByteString)
19 import Data.ByteString.Char8 as C8
20 import qualified Data.ByteString.Lazy.Char8 as L8
21 import qualified Data.Sequence as S
22 import Data.Sequence (Seq)
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.Headers
26 import Network.HTTP.Lucu.HttpVersion
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
30 data Interaction = Interaction {
32 , itrRemoteAddr :: !SockAddr
33 , itrResourcePath :: !(Maybe [String])
34 , itrRequest :: !(TVar (Maybe Request))
35 , itrResponse :: !(TVar Response)
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 LazyByteString) -- Resource が受領した部分は削除される
48 , itrWillReceiveBody :: !(TVar Bool)
49 , itrWillChunkBody :: !(TVar Bool)
50 , itrWillDiscardBody :: !(TVar Bool)
51 , itrWillClose :: !(TVar Bool)
53 , itrBodyToSend :: !(TVar LazyByteString)
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 :: ByteString
79 defaultPageContentType = C8.pack "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 = toHeaders [(C8.pack "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 L8.empty
103 willReceiveBody <- newTVarIO False
104 willChunkBody <- newTVarIO False
105 willDiscardBody <- newTVarIO False
106 willClose <- newTVarIO False
108 bodyToSend <- newTVarIO L8.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 () #-}