4 , ExistentialQuantification
9 module Network.HTTP.Lucu.Interaction
12 , EndOfInteraction(..)
14 , SyntacticallyInvalidInteraction(..)
15 , mkSyntacticallyInvalidInteraction
17 , SemanticallyInvalidInteraction(..)
18 , mkSemanticallyInvalidInteraction
20 , NormalInteraction(..)
21 , InteractionState(..)
22 , ReceiveBodyRequest(..)
32 import Blaze.ByteString.Builder (Builder)
33 import Control.Applicative
34 import Control.Concurrent.STM
35 import Data.Ascii (Ascii)
36 import Data.ByteString (ByteString)
37 import Data.Convertible.Base
38 import Data.Monoid.Unicode
39 import Data.Sequence (Seq)
42 import Data.Time.Format.HTTP
45 import Network.HTTP.Lucu.Config
46 import Network.HTTP.Lucu.DefaultPage
47 import Network.HTTP.Lucu.Headers
48 import Network.HTTP.Lucu.Preprocess
49 import Network.HTTP.Lucu.Request
50 import Network.HTTP.Lucu.Response
51 import Network.HTTP.Lucu.Response.StatusCode
52 import Network.HTTP.Lucu.Utils
56 import Prelude.Unicode
58 class Typeable i ⇒ Interaction i where
59 toInteraction ∷ i → SomeInteraction
60 toInteraction = SomeInteraction
62 fromInteraction ∷ SomeInteraction → Maybe i
63 fromInteraction (SomeInteraction i) = cast i
66 = ∀i. Interaction i ⇒ SomeInteraction !i
69 instance Interaction SomeInteraction where
71 fromInteraction = Just
73 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
74 -- (possibly pipelined) requests. The connection has already been
75 -- closed so no need to reply anything.
76 data EndOfInteraction = EndOfInteraction
78 instance Interaction EndOfInteraction
80 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
81 -- a syntactically valid 'Request'. The response code will always be
83 data SyntacticallyInvalidInteraction
85 syiResponse ∷ !Response
86 , syiBodyToSend ∷ !Builder
89 instance Interaction SyntacticallyInvalidInteraction
91 mkSyntacticallyInvalidInteraction ∷ Config
92 → IO SyntacticallyInvalidInteraction
93 mkSyntacticallyInvalidInteraction conf@(Config {..})
94 = do date ← getCurrentDate
95 let res = setHeader "Server" cnfServerSoftware $
96 setHeader "Date" date $
97 setHeader "Content-Type" defaultPageContentType $
98 emptyResponse BadRequest
99 body = defaultPageForResponse conf Nothing res
102 , syiBodyToSend = body
105 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
106 -- semantically valid 'Request'. The response code will always satisfy
108 data SemanticallyInvalidInteraction
110 seiRequest ∷ !Request
111 , seiExpectedContinue ∷ !Bool
112 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
114 , seiResponse ∷ !Response
115 , seiWillChunkBody ∷ !Bool
116 , seiWillClose ∷ !Bool
117 , seiBodyToSend ∷ !Builder
120 instance Interaction SemanticallyInvalidInteraction
122 mkSemanticallyInvalidInteraction ∷ Config
124 → IO SemanticallyInvalidInteraction
125 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
126 = do date ← getCurrentDate
127 let res = setHeader "Server" cnfServerSoftware $
128 setHeader "Date" date $
129 setHeader "Content-Type" defaultPageContentType $
131 then setHeader "Transfer-Encoding" "chunked"
135 then setHeader "Connection" "close"
138 emptyResponse arInitialStatus
139 body = defaultPageForResponse config (Just arRequest) res
141 seiRequest = arRequest
142 , seiExpectedContinue = arExpectedContinue
143 , seiReqBodyLength = arReqBodyLength
146 , seiWillChunkBody = arWillChunkBody
147 , seiWillClose = arWillClose
148 , seiBodyToSend = body
151 -- |'NormalInteraction' is an 'Interaction' with a semantically
152 -- correct 'Request'.
153 data NormalInteraction
156 , niRemoteAddr ∷ !SockAddr
157 #if defined(HAVE_SSL)
158 , niRemoteCert ∷ !(Maybe X509)
160 , niRequest ∷ !Request
161 , niResourcePath ∷ !Path
162 , niExpectedContinue ∷ !Bool
163 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
165 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
166 , niReceivedBody ∷ !(TMVar ByteString)
168 , niResponse ∷ !(TVar Response)
169 , niSendContinue ∷ !(TMVar Bool)
170 , niWillChunkBody ∷ !Bool
171 , niWillClose ∷ !(TVar Bool)
172 , niResponseHasCType ∷ !(TVar Bool)
173 -- FIXME: use TBChan Builder (in stm-chans package)
174 , niBodyToSend ∷ !(TMVar Builder)
176 , niState ∷ !(TVar InteractionState)
179 instance Interaction NormalInteraction
181 data ReceiveBodyRequest
182 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
186 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
188 data InteractionState
194 deriving (Show, Eq, Ord, Enum)
196 mkNormalInteraction ∷ Config
198 #if defined(HAVE_SSL)
203 → IO NormalInteraction
204 #if defined(HAVE_SSL)
205 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
207 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
209 = do receiveBodyReq ← newEmptyTMVarIO
210 receivedBody ← newEmptyTMVarIO
212 response ← newTVarIO $ emptyResponse arInitialStatus
213 sendContinue ← newEmptyTMVarIO
214 willClose ← newTVarIO arWillClose
215 responseHasCType ← newTVarIO False
216 bodyToSend ← newEmptyTMVarIO
218 state ← newTVarIO ExaminingRequest
222 , niRemoteAddr = remoteAddr
223 #if defined(HAVE_SSL)
224 , niRemoteCert = remoteCert
226 , niRequest = arRequest
227 , niResourcePath = rsrcPath
228 , niExpectedContinue = arExpectedContinue
229 , niReqBodyLength = arReqBodyLength
231 , niReceiveBodyReq = receiveBodyReq
232 , niReceivedBody = receivedBody
234 , niResponse = response
235 , niSendContinue = sendContinue
236 , niWillChunkBody = arWillChunkBody
237 , niWillClose = willClose
238 , niResponseHasCType = responseHasCType
239 , niBodyToSend = bodyToSend
244 type InteractionQueue = TVar (Seq SomeInteraction)
246 mkInteractionQueue ∷ IO InteractionQueue
247 {-# INLINE mkInteractionQueue #-}
248 mkInteractionQueue = newTVarIO (∅)
250 getCurrentDate ∷ IO Ascii
251 {-# INLINE getCurrentDate #-}
252 getCurrentDate = formatUTCTime <$> getCurrentTime
254 formatUTCTime ∷ UTCTime → Ascii
255 {-# INLINE formatUTCTime #-}
256 formatUTCTime = cs' ∘ Tagged
258 cs' ∷ Tagged HTTP UTCTime → Ascii