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.Monoid.Unicode
37 import Data.Sequence (Seq)
39 import qualified Data.Time.HTTP as HTTP
42 import Network.HTTP.Lucu.Config
43 import Network.HTTP.Lucu.DefaultPage
44 import Network.HTTP.Lucu.Headers
45 import Network.HTTP.Lucu.Preprocess
46 import Network.HTTP.Lucu.Request
47 import Network.HTTP.Lucu.Response
48 import Network.HTTP.Lucu.Utils
53 class Typeable i ⇒ Interaction i where
54 toInteraction ∷ i → SomeInteraction
55 toInteraction = SomeInteraction
57 fromInteraction ∷ SomeInteraction → Maybe i
58 fromInteraction (SomeInteraction i) = cast i
61 = ∀i. Interaction i ⇒ SomeInteraction !i
64 instance Interaction SomeInteraction where
66 fromInteraction = Just
68 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
69 -- (possibly pipelined) requests. The connection has already been
70 -- closed so no need to reply anything.
71 data EndOfInteraction = EndOfInteraction
73 instance Interaction EndOfInteraction
75 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
76 -- a syntactically valid 'Request'. The response code will always be
78 data SyntacticallyInvalidInteraction
80 syiResponse ∷ !Response
81 , syiBodyToSend ∷ !Builder
84 instance Interaction SyntacticallyInvalidInteraction
86 mkSyntacticallyInvalidInteraction ∷ Config
87 → IO SyntacticallyInvalidInteraction
88 mkSyntacticallyInvalidInteraction conf@(Config {..})
89 = do date ← getCurrentDate
90 let res = setHeader "Server" cnfServerSoftware $
91 setHeader "Date" date $
92 setHeader "Content-Type" defaultPageContentType $
93 emptyResponse BadRequest
94 body = defaultPageForResponse conf Nothing res
97 , syiBodyToSend = body
100 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
101 -- semantically valid 'Request'. The response code will always satisfy
103 data SemanticallyInvalidInteraction
105 seiRequest ∷ !Request
106 , seiExpectedContinue ∷ !Bool
107 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
109 , seiResponse ∷ !Response
110 , seiWillChunkBody ∷ !Bool
111 , seiWillDiscardBody ∷ !Bool
112 , seiWillClose ∷ !Bool
113 , seiBodyToSend ∷ !Builder
116 instance Interaction SemanticallyInvalidInteraction
118 mkSemanticallyInvalidInteraction ∷ Config
120 → IO SemanticallyInvalidInteraction
121 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
122 = do date ← getCurrentDate
123 let res = setHeader "Server" cnfServerSoftware $
124 setHeader "Date" date $
125 setHeader "Content-Type" defaultPageContentType $
127 then setHeader "Transfer-Encoding" "chunked"
131 then setHeader "Connection" "close"
134 emptyResponse arInitialStatus
135 body = defaultPageForResponse config (Just arRequest) res
137 seiRequest = arRequest
138 , seiExpectedContinue = arExpectedContinue
139 , seiReqBodyLength = arReqBodyLength
142 , seiWillChunkBody = arWillChunkBody
143 , seiWillDiscardBody = arWillDiscardBody
144 , seiWillClose = arWillClose
145 , seiBodyToSend = body
148 -- |'NormalInteraction' is an 'Interaction' with a semantically
149 -- correct 'Request'.
150 data NormalInteraction
153 , niRemoteAddr ∷ !SockAddr
154 #if defined(HAVE_SSL)
155 , niRemoteCert ∷ !(Maybe X509)
157 , niRequest ∷ !Request
158 , niResourcePath ∷ !Path
159 , niExpectedContinue ∷ !Bool
160 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
162 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
163 , niReceivedBody ∷ !(TMVar ByteString)
165 , niResponse ∷ !(TVar Response)
166 , niSendContinue ∷ !(TMVar Bool)
167 , niWillChunkBody ∷ !Bool
168 , niWillDiscardBody ∷ !(TVar Bool)
169 , niWillClose ∷ !(TVar Bool)
170 , niResponseHasCType ∷ !(TVar Bool)
171 -- FIXME: use TBChan Builder (in stm-chans package)
172 , niBodyToSend ∷ !(TMVar Builder)
174 , niState ∷ !(TVar InteractionState)
177 instance Interaction NormalInteraction
179 data ReceiveBodyRequest
180 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
184 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
186 data InteractionState
192 deriving (Show, Eq, Ord, Enum)
194 mkNormalInteraction ∷ Config
196 #if defined(HAVE_SSL)
201 → IO NormalInteraction
202 #if defined(HAVE_SSL)
203 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
205 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
207 = do receiveBodyReq ← newEmptyTMVarIO
208 receivedBody ← newEmptyTMVarIO
210 response ← newTVarIO $ emptyResponse arInitialStatus
211 sendContinue ← newEmptyTMVarIO
212 willDiscardBody ← newTVarIO arWillDiscardBody
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 , niWillDiscardBody = willDiscardBody
237 , niWillClose = willClose
238 , niResponseHasCType = responseHasCType
239 , niBodyToSend = bodyToSend
244 type InteractionQueue = TVar (Seq SomeInteraction)
246 mkInteractionQueue ∷ IO InteractionQueue
247 mkInteractionQueue = newTVarIO (∅)
249 getCurrentDate ∷ IO Ascii
250 getCurrentDate = HTTP.toAscii <$> getCurrentTime