6 module Network.HTTP.Lucu.Interaction
12 , defaultPageContentType
21 import Control.Applicative
22 import Control.Concurrent.STM
23 import Data.Ascii (Ascii)
24 import qualified Data.ByteString as BS
25 import Data.Sequence (Seq)
26 import qualified Data.Sequence as S
28 import Network.HTTP.Lucu.Config
29 import Network.HTTP.Lucu.Headers
30 import Network.HTTP.Lucu.HttpVersion
31 import Network.HTTP.Lucu.Request
32 import Network.HTTP.Lucu.Response
34 import Prelude.Unicode
36 data Interaction = Interaction {
38 , itrLocalPort ∷ !PortNumber
39 , itrRemoteAddr ∷ !SockAddr
40 , itrRemoteCert ∷ !(Maybe X509)
41 , itrResourcePath ∷ !(Maybe [Ascii])
42 , itrRequest ∷ !(TVar (Maybe Request))
43 , itrResponse ∷ !(TVar Response)
45 , itrRequestHasBody ∷ !(TVar Bool)
46 , itrRequestIsChunked ∷ !(TVar Bool)
47 , itrExpectedContinue ∷ !(TVar Bool)
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 (Seq BS.ByteString))
56 , itrWillReceiveBody ∷ !(TVar Bool)
57 , itrWillChunkBody ∷ !(TVar Bool)
58 , itrWillDiscardBody ∷ !(TVar Bool)
59 , itrWillClose ∷ !(TVar Bool)
61 , itrBodyToSend ∷ !(TVar (Seq BS.ByteString))
62 , itrBodyIsNull ∷ !(TVar Bool)
64 , itrState ∷ !(TVar InteractionState)
66 , itrWroteContinue ∷ !(TVar Bool)
67 , itrWroteHeader ∷ !(TVar Bool)
70 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
72 data InteractionState = ExaminingRequest
77 deriving (Show, Eq, Ord, Enum)
79 type InteractionQueue = TVar (Seq Interaction)
81 newInteractionQueue ∷ IO InteractionQueue
82 newInteractionQueue = newTVarIO S.empty
84 defaultPageContentType ∷ Ascii
85 defaultPageContentType = "application/xhtml+xml"
87 newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
88 newInteraction !conf !port !addr !cert !req
89 = do request ← newTVarIO req
90 responce ← newTVarIO Response {
91 resVersion = HttpVersion 1 1
93 , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
96 requestHasBody ← newTVarIO False
97 requestIsChunked ← newTVarIO False
98 expectedContinue ← newTVarIO False
100 reqChunkLength ← newTVarIO Nothing -- 現在のチャンク長
101 reqChunkRemaining ← newTVarIO Nothing -- 現在のチャンクの殘り
102 reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた
103 reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
104 reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
105 receivedBody ← newTVarIO S.empty
107 willReceiveBody ← newTVarIO False
108 willChunkBody ← newTVarIO False
109 willDiscardBody ← newTVarIO False
110 willClose ← newTVarIO False
112 bodyToSend ← newTVarIO S.empty
113 bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
115 state ← newTVarIO ExaminingRequest
117 wroteContinue ← newTVarIO False
118 wroteHeader ← newTVarIO False
122 , itrLocalPort = port
123 , itrRemoteAddr = addr
124 , itrRemoteCert = cert
125 , itrResourcePath = Nothing
126 , itrRequest = request
127 , itrResponse = responce
129 , itrRequestHasBody = requestHasBody
130 , itrRequestIsChunked = requestIsChunked
131 , itrExpectedContinue = expectedContinue
133 , itrReqChunkLength = reqChunkLength
134 , itrReqChunkRemaining = reqChunkRemaining
135 , itrReqChunkIsOver = reqChunkIsOver
136 , itrReqBodyWanted = reqBodyWanted
137 , itrReqBodyWasteAll = reqBodyWasteAll
138 , itrReceivedBody = receivedBody
140 , itrWillReceiveBody = willReceiveBody
141 , itrWillChunkBody = willChunkBody
142 , itrWillDiscardBody = willDiscardBody
143 , itrWillClose = willClose
145 , itrBodyToSend = bodyToSend
146 , itrBodyIsNull = bodyIsNull
150 , itrWroteContinue = wroteContinue
151 , itrWroteHeader = wroteHeader
154 writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
155 {-# INLINE writeItr #-}
156 writeItr itr accessor
157 = writeTVar (accessor itr)
159 readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
160 {-# INLINE readItr #-}
161 readItr itr accessor reader
162 = reader <$> readTVar (accessor itr)
164 readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
165 {-# INLINE readItrF #-}
166 readItrF itr accessor reader
167 = readItr itr accessor (fmap reader)
169 updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
170 {-# INLINE updateItr #-}
171 updateItr itr accessor updator
172 = do old ← readItr itr accessor id
173 writeItr itr accessor (updator old)
175 updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
176 {-# INLINE updateItrF #-}
177 updateItrF itr accessor
178 = updateItr itr accessor ∘ fmap