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.Response.StatusCode
51 import Network.HTTP.Lucu.Utils
55 import Prelude.Unicode
57 class Typeable i ⇒ Interaction i where
58 toInteraction ∷ i → SomeInteraction
59 toInteraction = SomeInteraction
61 fromInteraction ∷ SomeInteraction → Maybe i
62 fromInteraction (SomeInteraction i) = cast i
65 = ∀i. Interaction i ⇒ SomeInteraction !i
68 instance Interaction SomeInteraction where
70 fromInteraction = Just
72 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
73 -- (possibly pipelined) requests. The connection has already been
74 -- closed so no need to reply anything.
75 data EndOfInteraction = EndOfInteraction
77 instance Interaction EndOfInteraction
79 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
80 -- a syntactically valid 'Request'. The response code will always be
82 data SyntacticallyInvalidInteraction
84 syiResponse ∷ !Response
85 , syiBodyToSend ∷ !Builder
88 instance Interaction SyntacticallyInvalidInteraction
90 mkSyntacticallyInvalidInteraction ∷ Config
91 → IO SyntacticallyInvalidInteraction
92 mkSyntacticallyInvalidInteraction conf@(Config {..})
93 = do date ← getCurrentDate
94 let res = setHeader "Server" cnfServerSoftware $
95 setHeader "Date" date $
96 setHeader "Content-Type" defaultPageContentType $
97 emptyResponse BadRequest
98 body = defaultPageForResponse conf Nothing res
101 , syiBodyToSend = body
104 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
105 -- semantically valid 'Request'. The response code will always satisfy
107 data SemanticallyInvalidInteraction
109 seiRequest ∷ !Request
110 , seiExpectedContinue ∷ !Bool
111 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
113 , seiResponse ∷ !Response
114 , seiWillChunkBody ∷ !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 , seiWillClose = arWillClose
147 , seiBodyToSend = body
150 -- |'NormalInteraction' is an 'Interaction' with a semantically
151 -- correct 'Request'.
152 data NormalInteraction
155 , niRemoteAddr ∷ !SockAddr
156 #if defined(HAVE_SSL)
157 , niRemoteCert ∷ !(Maybe X509)
159 , niRequest ∷ !Request
160 , niResourcePath ∷ !Path
161 , niExpectedContinue ∷ !Bool
162 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
164 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
165 , niReceivedBody ∷ !(TMVar ByteString)
167 , niResponse ∷ !(TVar Response)
168 , niSendContinue ∷ !(TMVar Bool)
169 , niWillChunkBody ∷ !Bool
170 , niWillClose ∷ !(TVar Bool)
171 , niResponseHasCType ∷ !(TVar Bool)
172 -- FIXME: use TBChan Builder (in stm-chans package)
173 , niBodyToSend ∷ !(TMVar Builder)
175 , niState ∷ !(TVar InteractionState)
178 instance Interaction NormalInteraction
180 data ReceiveBodyRequest
181 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
185 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
187 data InteractionState
193 deriving (Show, Eq, Ord, Enum)
195 mkNormalInteraction ∷ Config
197 #if defined(HAVE_SSL)
202 → IO NormalInteraction
203 #if defined(HAVE_SSL)
204 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
206 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
208 = do receiveBodyReq ← newEmptyTMVarIO
209 receivedBody ← newEmptyTMVarIO
211 response ← newTVarIO $ emptyResponse arInitialStatus
212 sendContinue ← newEmptyTMVarIO
213 willClose ← newTVarIO arWillClose
214 responseHasCType ← newTVarIO False
215 bodyToSend ← newEmptyTMVarIO
217 state ← newTVarIO ExaminingRequest
221 , niRemoteAddr = remoteAddr
222 #if defined(HAVE_SSL)
223 , niRemoteCert = remoteCert
225 , niRequest = arRequest
226 , niResourcePath = rsrcPath
227 , niExpectedContinue = arExpectedContinue
228 , niReqBodyLength = arReqBodyLength
230 , niReceiveBodyReq = receiveBodyReq
231 , niReceivedBody = receivedBody
233 , niResponse = response
234 , niSendContinue = sendContinue
235 , niWillChunkBody = arWillChunkBody
236 , niWillClose = willClose
237 , niResponseHasCType = responseHasCType
238 , niBodyToSend = bodyToSend
243 type InteractionQueue = TVar (Seq SomeInteraction)
245 mkInteractionQueue ∷ IO InteractionQueue
246 {-# INLINE mkInteractionQueue #-}
247 mkInteractionQueue = newTVarIO (∅)
249 getCurrentDate ∷ IO Ascii
250 {-# INLINE getCurrentDate #-}
251 getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime