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 , itrLocalPort :: !PortNumber
35 , itrRemoteAddr :: !SockAddr
36 , itrRemoteCert :: !(Maybe X509)
37 , itrResourcePath :: !(Maybe [String])
38 , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
39 , itrResponse :: !(TVar Response)
41 , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し
42 , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し
43 , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し
45 , itrReqChunkLength :: !(TVar (Maybe Int))
46 , itrReqChunkRemaining :: !(TVar (Maybe Int))
47 , itrReqChunkIsOver :: !(TVar Bool)
48 , itrReqBodyWanted :: !(TVar (Maybe Int))
49 , itrReqBodyWasteAll :: !(TVar Bool)
50 , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
52 , itrWillReceiveBody :: !(TVar Bool)
53 , itrWillChunkBody :: !(TVar Bool)
54 , itrWillDiscardBody :: !(TVar Bool)
55 , itrWillClose :: !(TVar Bool)
57 , itrBodyToSend :: !(TVar Lazy.ByteString)
58 , itrBodyIsNull :: !(TVar Bool)
60 , itrState :: !(TVar InteractionState)
62 , itrWroteContinue :: !(TVar Bool)
63 , itrWroteHeader :: !(TVar Bool)
66 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
67 -- 状態は ExaminingRequest。
68 data InteractionState = ExaminingRequest
73 deriving (Show, Eq, Ord, Enum)
75 type InteractionQueue = TVar (Seq Interaction)
78 newInteractionQueue :: IO InteractionQueue
79 newInteractionQueue = newTVarIO S.empty
82 defaultPageContentType :: Strict.ByteString
83 defaultPageContentType = C8.pack "application/xhtml+xml"
86 newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
87 newInteraction !conf !port !addr !cert !req
88 = do request <- newTVarIO req
89 responce <- newTVarIO Response {
90 resVersion = HttpVersion 1 1
92 , resHeaders = toHeaders [(C8.pack "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 L8.empty
106 willReceiveBody <- newTVarIO False
107 willChunkBody <- newTVarIO False
108 willDiscardBody <- newTVarIO False
109 willClose <- newTVarIO False
111 bodyToSend <- newTVarIO L8.empty
112 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
114 state <- newTVarIO ExaminingRequest
116 wroteContinue <- newTVarIO False
117 wroteHeader <- newTVarIO False
121 , itrLocalPort = port
122 , itrRemoteAddr = addr
123 , itrRemoteCert = cert
124 , itrResourcePath = Nothing
125 , itrRequest = request
126 , itrResponse = responce
128 , itrRequestHasBody = requestHasBody
129 , itrRequestIsChunked = requestIsChunked
130 , itrExpectedContinue = expectedContinue
132 , itrReqChunkLength = reqChunkLength
133 , itrReqChunkRemaining = reqChunkRemaining
134 , itrReqChunkIsOver = reqChunkIsOver
135 , itrReqBodyWanted = reqBodyWanted
136 , itrReqBodyWasteAll = reqBodyWasteAll
137 , itrReceivedBody = receivedBody
139 , itrWillReceiveBody = willReceiveBody
140 , itrWillChunkBody = willChunkBody
141 , itrWillDiscardBody = willDiscardBody
142 , itrWillClose = willClose
144 , itrBodyToSend = bodyToSend
145 , itrBodyIsNull = bodyIsNull
149 , itrWroteContinue = wroteContinue
150 , itrWroteHeader = wroteHeader
154 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
155 writeItr !itr !accessor !value
156 = writeTVar (accessor itr) value
159 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
160 readItr !itr !accessor !reader
161 = fmap reader $ readTVar (accessor itr)
164 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
165 readItrF !itr !accessor !reader
166 = readItr itr accessor (fmap reader)
167 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
170 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
171 updateItr !itr !accessor !updator
172 = do old <- readItr itr accessor id
173 writeItr itr accessor (updator old)
176 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
177 updateItrF !itr !accessor !updator
178 = updateItr itr accessor (fmap updator)
179 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}