6 module Network.HTTP.Lucu.Interaction
12 , defaultPageContentType
19 import Blaze.ByteString.Builder (Builder)
20 import Control.Concurrent.STM
21 import Data.Ascii (Ascii)
22 import qualified Data.ByteString as BS
23 import Data.Sequence (Seq)
24 import qualified Data.Sequence as S
25 import Data.Text (Text)
27 import Network.HTTP.Lucu.Config
28 import Network.HTTP.Lucu.Headers
29 import Network.HTTP.Lucu.HttpVersion
30 import Network.HTTP.Lucu.Request
31 import Network.HTTP.Lucu.Response
34 data Interaction = Interaction {
36 , itrLocalPort ∷ !PortNumber
37 , itrRemoteAddr ∷ !SockAddr
38 , itrRemoteCert ∷ !(Maybe X509)
39 , itrResourcePath ∷ !(Maybe [Text])
40 , itrRequest ∷ !(TVar (Maybe Request))
41 , itrResponse ∷ !(TVar Response)
43 , itrRequestHasBody ∷ !(TVar Bool)
44 , itrRequestIsChunked ∷ !(TVar Bool)
45 , itrExpectedContinue ∷ !(TVar Bool)
47 , itrReqChunkLength ∷ !(TVar (Maybe Int))
48 , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
49 , itrReqChunkIsOver ∷ !(TVar Bool)
50 , itrReqBodyWanted ∷ !(TVar (Maybe Int))
51 , itrReqBodyWasteAll ∷ !(TVar Bool)
52 , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
53 , itrReceivedBodyLen ∷ !(TVar Int)
55 , itrWillReceiveBody ∷ !(TVar Bool)
56 , itrWillChunkBody ∷ !(TVar Bool)
57 , itrWillDiscardBody ∷ !(TVar Bool)
58 , itrWillClose ∷ !(TVar Bool)
60 , itrBodyToSend ∷ !(TMVar Builder)
61 , itrSentNoBody ∷ !(TVar Bool)
63 , itrState ∷ !(TVar InteractionState)
65 , itrWroteContinue ∷ !(TVar Bool)
66 , itrWroteHeader ∷ !(TVar Bool)
69 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
71 data InteractionState = ExaminingRequest
76 deriving (Show, Eq, Ord, Enum)
78 type InteractionQueue = TVar (Seq Interaction)
80 newInteractionQueue ∷ IO InteractionQueue
81 newInteractionQueue = newTVarIO S.empty
83 defaultPageContentType ∷ Ascii
84 defaultPageContentType = "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 [("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 S.empty
105 receivedBodyLen ← newTVarIO 0
107 willReceiveBody ← newTVarIO False
108 willChunkBody ← newTVarIO False
109 willDiscardBody ← newTVarIO False
110 willClose ← newTVarIO False
112 bodyToSend ← newEmptyTMVarIO
113 sentNoBody ← 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
139 , itrReceivedBodyLen = receivedBodyLen
141 , itrWillReceiveBody = willReceiveBody
142 , itrWillChunkBody = willChunkBody
143 , itrWillDiscardBody = willDiscardBody
144 , itrWillClose = willClose
146 , itrBodyToSend = bodyToSend
147 , itrSentNoBody = sentNoBody
151 , itrWroteContinue = wroteContinue
152 , itrWroteHeader = wroteHeader
156 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
157 {-# INLINE chunksToLBS #-}
158 chunksToLBS = LBS.fromChunks ∘ toList
160 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
161 {-# INLINE chunksFromLBS #-}
162 chunksFromLBS = S.fromList ∘ LBS.toChunks
165 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
166 {-# INLINE writeItr #-}
167 writeItr accessor a itr
168 = writeTVar (accessor itr) a
170 readItr ∷ (Interaction → TVar a) → Interaction → STM a
171 {-# INLINE readItr #-}
173 = readTVar (accessor itr)
175 updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
176 {-# INLINE updateItr #-}
177 updateItr accessor updator itr
178 = do old ← readItr accessor itr
179 writeItr accessor (updator old) itr