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
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 = writeTVar (accessor itr) value
157 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
158 readItr !itr !accessor !reader
159 = fmap reader $ readTVar (accessor itr)
162 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
163 readItrF !itr !accessor !reader
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 = do old <- readItr itr accessor id
171 writeItr itr accessor (updator old)
174 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
175 updateItrF !itr !accessor !updator
176 = updateItr itr accessor (fmap updator)
177 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}