5 module Network.HTTP.Lucu.Interaction
11 , defaultPageContentType
21 import Control.Concurrent.STM
22 import qualified Data.ByteString as Strict (ByteString)
23 import qualified Data.ByteString.Lazy as Lazy (ByteString)
24 import Data.ByteString.Char8 as C8 hiding (ByteString)
25 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
26 import qualified Data.Sequence as S
27 import Data.Sequence (Seq)
29 import Network.HTTP.Lucu.Config
30 import Network.HTTP.Lucu.Headers
31 import Network.HTTP.Lucu.HttpVersion
32 import Network.HTTP.Lucu.Request
33 import Network.HTTP.Lucu.Response
36 data Interaction = Interaction {
38 , itrLocalPort :: !PortNumber
39 , itrRemoteAddr :: !SockAddr
40 , itrRemoteCert :: !(Maybe X509)
41 , itrResourcePath :: !(Maybe [String])
42 , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
43 , itrResponse :: !(TVar Response)
45 , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し
46 , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し
47 , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し
49 , itrReqChunkLength :: !(TVar (Maybe Int))
50 , itrReqChunkRemaining :: !(TVar (Maybe Int))
51 , itrReqChunkIsOver :: !(TVar Bool)
52 , itrReqBodyWanted :: !(TVar (Maybe Int))
53 , itrReqBodyWasteAll :: !(TVar Bool)
54 , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
56 , itrWillReceiveBody :: !(TVar Bool)
57 , itrWillChunkBody :: !(TVar Bool)
58 , itrWillDiscardBody :: !(TVar Bool)
59 , itrWillClose :: !(TVar Bool)
61 , itrBodyToSend :: !(TVar Lazy.ByteString)
62 , itrBodyIsNull :: !(TVar Bool)
64 , itrState :: !(TVar InteractionState)
66 , itrWroteContinue :: !(TVar Bool)
67 , itrWroteHeader :: !(TVar Bool)
70 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
71 -- 状態は ExaminingRequest。
72 data InteractionState = ExaminingRequest
77 deriving (Show, Eq, Ord, Enum)
79 type InteractionQueue = TVar (Seq Interaction)
82 newInteractionQueue :: IO InteractionQueue
83 newInteractionQueue = newTVarIO S.empty
86 defaultPageContentType :: Strict.ByteString
87 defaultPageContentType = C8.pack "application/xhtml+xml"
90 newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
91 newInteraction !conf !port !addr !cert !req
92 = do request <- newTVarIO req
93 responce <- newTVarIO Response {
94 resVersion = HttpVersion 1 1
96 , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
99 requestHasBody <- newTVarIO False
100 requestIsChunked <- newTVarIO False
101 expectedContinue <- newTVarIO False
103 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
104 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
105 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
106 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
107 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
108 receivedBody <- newTVarIO L8.empty
110 willReceiveBody <- newTVarIO False
111 willChunkBody <- newTVarIO False
112 willDiscardBody <- newTVarIO False
113 willClose <- newTVarIO False
115 bodyToSend <- newTVarIO L8.empty
116 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
118 state <- newTVarIO ExaminingRequest
120 wroteContinue <- newTVarIO False
121 wroteHeader <- newTVarIO False
125 , itrLocalPort = port
126 , itrRemoteAddr = addr
127 , itrRemoteCert = cert
128 , itrResourcePath = Nothing
129 , itrRequest = request
130 , itrResponse = responce
132 , itrRequestHasBody = requestHasBody
133 , itrRequestIsChunked = requestIsChunked
134 , itrExpectedContinue = expectedContinue
136 , itrReqChunkLength = reqChunkLength
137 , itrReqChunkRemaining = reqChunkRemaining
138 , itrReqChunkIsOver = reqChunkIsOver
139 , itrReqBodyWanted = reqBodyWanted
140 , itrReqBodyWasteAll = reqBodyWasteAll
141 , itrReceivedBody = receivedBody
143 , itrWillReceiveBody = willReceiveBody
144 , itrWillChunkBody = willChunkBody
145 , itrWillDiscardBody = willDiscardBody
146 , itrWillClose = willClose
148 , itrBodyToSend = bodyToSend
149 , itrBodyIsNull = bodyIsNull
153 , itrWroteContinue = wroteContinue
154 , itrWroteHeader = wroteHeader
158 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
159 writeItr !itr !accessor !value
160 = writeTVar (accessor itr) value
163 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
164 readItr !itr !accessor !reader
165 = fmap reader $ readTVar (accessor itr)
168 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
169 readItrF !itr !accessor !reader
170 = readItr itr accessor (fmap reader)
171 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
174 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
175 updateItr !itr !accessor !updator
176 = do old <- readItr itr accessor id
177 writeItr itr accessor (updator old)
180 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
181 updateItrF !itr !accessor !updator
182 = updateItr itr accessor (fmap updator)
183 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}