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
32 data Interaction = Interaction {
34 , itrRemoteAddr :: !SockAddr
35 , itrRemoteCert :: !(Maybe X509)
36 , itrResourcePath :: !(Maybe [String])
37 , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
38 , itrResponse :: !(TVar Response)
40 , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し
41 , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し
42 , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し
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 Lazy.ByteString) -- Resource が受領した部分は削除される
51 , itrWillReceiveBody :: !(TVar Bool)
52 , itrWillChunkBody :: !(TVar Bool)
53 , itrWillDiscardBody :: !(TVar Bool)
54 , itrWillClose :: !(TVar Bool)
56 , itrBodyToSend :: !(TVar Lazy.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 :: Strict.ByteString
82 defaultPageContentType = C8.pack "application/xhtml+xml"
85 newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
86 newInteraction !conf !addr !cert !req
87 = do request <- newTVarIO $ req
88 responce <- newTVarIO $ Response {
89 resVersion = HttpVersion 1 1
91 , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
94 requestHasBody <- newTVarIO False
95 requestIsChunked <- newTVarIO False
96 expectedContinue <- newTVarIO False
98 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
99 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
100 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
101 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
102 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
103 receivedBody <- newTVarIO L8.empty
105 willReceiveBody <- newTVarIO False
106 willChunkBody <- newTVarIO False
107 willDiscardBody <- newTVarIO False
108 willClose <- newTVarIO False
110 bodyToSend <- newTVarIO L8.empty
111 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
113 state <- newTVarIO ExaminingRequest
115 wroteContinue <- newTVarIO False
116 wroteHeader <- newTVarIO False
118 return $ Interaction {
120 , itrRemoteAddr = addr
121 , itrRemoteCert = cert
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 () #-}