6 module Network.HTTP.Lucu.Interaction
12 , defaultPageContentType
19 import Blaze.ByteString.Builder (Builder)
20 import Control.Applicative
21 import Control.Concurrent.STM
22 import Data.Ascii (Ascii)
23 import qualified Data.ByteString as BS
24 import Data.Sequence (Seq)
25 import qualified Data.Sequence as S
26 import Data.Text (Text)
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
35 data Interaction = Interaction {
37 , itrLocalPort ∷ !PortNumber
38 , itrRemoteAddr ∷ !SockAddr
39 , itrRemoteCert ∷ !(Maybe X509)
40 , itrResourcePath ∷ !(Maybe [Text])
41 , itrRequest ∷ !(TVar (Maybe Request))
42 , itrResponse ∷ !(TVar Response)
44 , itrRequestHasBody ∷ !(TVar Bool)
45 , itrRequestIsChunked ∷ !(TVar Bool)
46 , itrExpectedContinue ∷ !(TVar Bool)
48 , itrReqChunkLength ∷ !(TVar (Maybe Int))
49 , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
50 , itrReqChunkIsOver ∷ !(TVar Bool)
51 , itrReqBodyWanted ∷ !(TVar (Maybe Int))
52 , itrReqBodyWasteAll ∷ !(TVar Bool)
53 , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
54 , itrReceivedBodyLen ∷ !(TVar Int)
56 , itrWillReceiveBody ∷ !(TVar Bool)
57 , itrWillChunkBody ∷ !(TVar Bool)
58 , itrWillDiscardBody ∷ !(TVar Bool)
59 , itrWillClose ∷ !(TVar Bool)
61 , itrBodyToSend ∷ !(TMVar Builder)
62 , itrSentNoBody ∷ !(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
106 receivedBodyLen ← newTVarIO 0
108 willReceiveBody ← newTVarIO False
109 willChunkBody ← newTVarIO False
110 willDiscardBody ← newTVarIO False
111 willClose ← newTVarIO False
113 bodyToSend ← newEmptyTMVarIO
114 sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
116 state ← newTVarIO ExaminingRequest
118 wroteContinue ← newTVarIO False
119 wroteHeader ← newTVarIO False
123 , itrLocalPort = port
124 , itrRemoteAddr = addr
125 , itrRemoteCert = cert
126 , itrResourcePath = Nothing
127 , itrRequest = request
128 , itrResponse = responce
130 , itrRequestHasBody = requestHasBody
131 , itrRequestIsChunked = requestIsChunked
132 , itrExpectedContinue = expectedContinue
134 , itrReqChunkLength = reqChunkLength
135 , itrReqChunkRemaining = reqChunkRemaining
136 , itrReqChunkIsOver = reqChunkIsOver
137 , itrReqBodyWanted = reqBodyWanted
138 , itrReqBodyWasteAll = reqBodyWasteAll
139 , itrReceivedBody = receivedBody
140 , itrReceivedBodyLen = receivedBodyLen
142 , itrWillReceiveBody = willReceiveBody
143 , itrWillChunkBody = willChunkBody
144 , itrWillDiscardBody = willDiscardBody
145 , itrWillClose = willClose
147 , itrBodyToSend = bodyToSend
148 , itrSentNoBody = sentNoBody
152 , itrWroteContinue = wroteContinue
153 , itrWroteHeader = wroteHeader
157 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
158 {-# INLINE chunksToLBS #-}
159 chunksToLBS = LBS.fromChunks ∘ toList
161 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
162 {-# INLINE chunksFromLBS #-}
163 chunksFromLBS = S.fromList ∘ LBS.toChunks
166 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
167 {-# INLINE writeItr #-}
168 writeItr accessor a itr
169 = writeTVar (accessor itr) a
171 readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b
172 {-# INLINE readItr #-}
173 readItr accessor reader itr
174 = reader <$> readTVar (accessor itr)
176 updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
177 {-# INLINE updateItr #-}
178 updateItr accessor updator itr
179 = do old ← readItr accessor id itr
180 writeItr accessor (updator old) itr