4 , ExistentialQuantification
9 module Network.HTTP.Lucu.Interaction
12 , EndOfInteraction(..)
14 , SyntacticallyInvalidInteraction(..)
15 , mkSyntacticallyInvalidInteraction
17 , SemanticallyInvalidInteraction(..)
18 , mkSemanticallyInvalidInteraction
20 , NormalInteraction(..)
21 , InteractionState(..)
22 , ReceiveBodyRequest(..)
31 import Blaze.ByteString.Builder (Builder)
32 import Control.Applicative
33 import Control.Concurrent.STM
34 import Data.Ascii (Ascii)
35 import Data.ByteString (ByteString)
36 import Data.Convertible.Base
37 import Data.Monoid.Unicode
39 import Data.Sequence (Seq)
41 import Data.Time.Format.HTTP
44 import Network.HTTP.Lucu.Config
45 import Network.HTTP.Lucu.DefaultPage
46 import Network.HTTP.Lucu.Headers
47 import Network.HTTP.Lucu.Preprocess
48 import Network.HTTP.Lucu.Request
49 import Network.HTTP.Lucu.Response
50 import Network.HTTP.Lucu.Utils
54 import Prelude.Unicode
56 class Typeable i ⇒ Interaction i where
57 toInteraction ∷ i → SomeInteraction
58 toInteraction = SomeInteraction
60 fromInteraction ∷ SomeInteraction → Maybe i
61 fromInteraction (SomeInteraction i) = cast i
64 = ∀i. Interaction i ⇒ SomeInteraction !i
67 instance Interaction SomeInteraction where
69 fromInteraction = Just
71 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
72 -- (possibly pipelined) requests. The connection has already been
73 -- closed so no need to reply anything.
74 data EndOfInteraction = EndOfInteraction
76 instance Interaction EndOfInteraction
78 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
79 -- a syntactically valid 'Request'. The response code will always be
81 data SyntacticallyInvalidInteraction
83 syiResponse ∷ !Response
84 , syiBodyToSend ∷ !Builder
87 instance Interaction SyntacticallyInvalidInteraction
89 mkSyntacticallyInvalidInteraction ∷ Config
90 → IO SyntacticallyInvalidInteraction
91 mkSyntacticallyInvalidInteraction conf@(Config {..})
92 = do date ← getCurrentDate
93 let res = setHeader "Server" cnfServerSoftware $
94 setHeader "Date" date $
95 setHeader "Content-Type" defaultPageContentType $
96 emptyResponse BadRequest
97 body = defaultPageForResponse conf Nothing res
100 , syiBodyToSend = body
103 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
104 -- semantically valid 'Request'. The response code will always satisfy
106 data SemanticallyInvalidInteraction
108 seiRequest ∷ !Request
109 , seiExpectedContinue ∷ !Bool
110 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
112 , seiResponse ∷ !Response
113 , seiWillChunkBody ∷ !Bool
114 , seiWillDiscardBody ∷ !Bool
115 , seiWillClose ∷ !Bool
116 , seiBodyToSend ∷ !Builder
119 instance Interaction SemanticallyInvalidInteraction
121 mkSemanticallyInvalidInteraction ∷ Config
123 → IO SemanticallyInvalidInteraction
124 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
125 = do date ← getCurrentDate
126 let res = setHeader "Server" cnfServerSoftware $
127 setHeader "Date" date $
128 setHeader "Content-Type" defaultPageContentType $
130 then setHeader "Transfer-Encoding" "chunked"
134 then setHeader "Connection" "close"
137 emptyResponse arInitialStatus
138 body = defaultPageForResponse config (Just arRequest) res
140 seiRequest = arRequest
141 , seiExpectedContinue = arExpectedContinue
142 , seiReqBodyLength = arReqBodyLength
145 , seiWillChunkBody = arWillChunkBody
146 , seiWillDiscardBody = arWillDiscardBody
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 , niWillDiscardBody ∷ !(TVar Bool)
172 , niWillClose ∷ !(TVar Bool)
173 , niResponseHasCType ∷ !(TVar Bool)
174 -- FIXME: use TBChan Builder (in stm-chans package)
175 , niBodyToSend ∷ !(TMVar Builder)
177 , niState ∷ !(TVar InteractionState)
180 instance Interaction NormalInteraction
182 data ReceiveBodyRequest
183 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
187 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
189 data InteractionState
195 deriving (Show, Eq, Ord, Enum)
197 mkNormalInteraction ∷ Config
199 #if defined(HAVE_SSL)
204 → IO NormalInteraction
205 #if defined(HAVE_SSL)
206 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
208 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
210 = do receiveBodyReq ← newEmptyTMVarIO
211 receivedBody ← newEmptyTMVarIO
213 response ← newTVarIO $ emptyResponse arInitialStatus
214 sendContinue ← newEmptyTMVarIO
215 willDiscardBody ← newTVarIO arWillDiscardBody
216 willClose ← newTVarIO arWillClose
217 responseHasCType ← newTVarIO False
218 bodyToSend ← newEmptyTMVarIO
220 state ← newTVarIO ExaminingRequest
224 , niRemoteAddr = remoteAddr
225 #if defined(HAVE_SSL)
226 , niRemoteCert = remoteCert
228 , niRequest = arRequest
229 , niResourcePath = rsrcPath
230 , niExpectedContinue = arExpectedContinue
231 , niReqBodyLength = arReqBodyLength
233 , niReceiveBodyReq = receiveBodyReq
234 , niReceivedBody = receivedBody
236 , niResponse = response
237 , niSendContinue = sendContinue
238 , niWillChunkBody = arWillChunkBody
239 , niWillDiscardBody = willDiscardBody
240 , niWillClose = willClose
241 , niResponseHasCType = responseHasCType
242 , niBodyToSend = bodyToSend
247 type InteractionQueue = TVar (Seq SomeInteraction)
249 mkInteractionQueue ∷ IO InteractionQueue
250 {-# INLINE mkInteractionQueue #-}
251 mkInteractionQueue = newTVarIO (∅)
253 getCurrentDate ∷ IO Ascii
254 {-# INLINE getCurrentDate #-}
255 getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime