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 qualified Data.ByteString as Strict
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
52 class Typeable i ⇒ Interaction i where
53 toInteraction ∷ i → SomeInteraction
54 toInteraction = SomeInteraction
56 fromInteraction ∷ SomeInteraction → Maybe i
57 fromInteraction (SomeInteraction i) = cast i
60 = ∀i. Interaction i ⇒ SomeInteraction !i
63 instance Interaction SomeInteraction where
65 fromInteraction = Just
67 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
68 -- (possibly pipelined) requests. The connection has already been
69 -- closed so no need to reply anything.
70 data EndOfInteraction = EndOfInteraction
72 instance Interaction EndOfInteraction
74 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
75 -- a syntactically valid 'Request'. The response code will always be
77 data SyntacticallyInvalidInteraction
79 syiResponse ∷ !Response
80 , syiBodyToSend ∷ !Builder
83 instance Interaction SyntacticallyInvalidInteraction
85 mkSyntacticallyInvalidInteraction ∷ Config
86 → IO SyntacticallyInvalidInteraction
87 mkSyntacticallyInvalidInteraction config@(Config {..})
88 = do date ← getCurrentDate
89 let res = setHeader "Server" cnfServerSoftware $
90 setHeader "Date" date $
91 setHeader "Content-Type" defaultPageContentType $
92 emptyResponse BadRequest
93 body = getDefaultPage config Nothing res
96 , syiBodyToSend = body
99 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
100 -- semantically valid 'Request'. The response code will always satisfy
102 data SemanticallyInvalidInteraction
104 seiRequest ∷ !Request
105 , seiExpectedContinue ∷ !Bool
106 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
108 , seiResponse ∷ !Response
109 , seiWillChunkBody ∷ !Bool
110 , seiWillDiscardBody ∷ !Bool
111 , seiWillClose ∷ !Bool
112 , seiBodyToSend ∷ !Builder
115 instance Interaction SemanticallyInvalidInteraction
117 mkSemanticallyInvalidInteraction ∷ Config
119 → IO SemanticallyInvalidInteraction
120 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
121 = do date ← getCurrentDate
122 let res = setHeader "Server" cnfServerSoftware $
123 setHeader "Date" date $
124 setHeader "Content-Type" defaultPageContentType $
125 emptyResponse arInitialStatus
126 body = getDefaultPage config (Just arRequest) res
128 seiRequest = arRequest
129 , seiExpectedContinue = arExpectedContinue
130 , seiReqBodyLength = arReqBodyLength
133 , seiWillChunkBody = arWillChunkBody
134 , seiWillDiscardBody = arWillDiscardBody
135 , seiWillClose = arWillClose
136 , seiBodyToSend = body
139 -- |'NormalInteraction' is an 'Interaction' with a semantically
140 -- correct 'Request'.
141 data NormalInteraction
144 , niRemoteAddr ∷ !SockAddr
145 #if defined(HAVE_SSL)
146 , niRemoteCert ∷ !(Maybe X509)
148 , niRequest ∷ !Request
149 , niResourcePath ∷ ![Strict.ByteString]
150 , niExpectedContinue ∷ !Bool
151 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
153 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
154 , niReceivedBody ∷ !(TMVar Strict.ByteString)
156 , niResponse ∷ !(TVar Response)
157 , niSendContinue ∷ !(TMVar Bool)
158 , niWillChunkBody ∷ !Bool
159 , niWillDiscardBody ∷ !(TVar Bool)
160 , niWillClose ∷ !(TVar Bool)
161 , niResponseHasCType ∷ !(TVar Bool)
162 -- FIXME: use TBChan Builder (in stm-chans package)
163 , niBodyToSend ∷ !(TMVar Builder)
165 , niState ∷ !(TVar InteractionState)
168 instance Interaction NormalInteraction
170 data ReceiveBodyRequest
171 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
175 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
177 data InteractionState
183 deriving (Show, Eq, Ord, Enum)
185 mkNormalInteraction ∷ Config
187 #if defined(HAVE_SSL)
191 → [Strict.ByteString]
192 → IO NormalInteraction
193 #if defined(HAVE_SSL)
194 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
196 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
198 = do receiveBodyReq ← newEmptyTMVarIO
199 receivedBody ← newEmptyTMVarIO
201 response ← newTVarIO $ emptyResponse arInitialStatus
202 sendContinue ← newEmptyTMVarIO
203 willDiscardBody ← newTVarIO arWillDiscardBody
204 willClose ← newTVarIO arWillClose
205 responseHasCType ← newTVarIO False
206 bodyToSend ← newEmptyTMVarIO
208 state ← newTVarIO ExaminingRequest
212 , niRemoteAddr = remoteAddr
213 #if defined(HAVE_SSL)
214 , niRemoteCert = remoteCert
216 , niRequest = arRequest
217 , niResourcePath = rsrcPath
218 , niExpectedContinue = arExpectedContinue
219 , niReqBodyLength = arReqBodyLength
221 , niReceiveBodyReq = receiveBodyReq
222 , niReceivedBody = receivedBody
224 , niResponse = response
225 , niSendContinue = sendContinue
226 , niWillChunkBody = arWillChunkBody
227 , niWillDiscardBody = willDiscardBody
228 , niWillClose = willClose
229 , niResponseHasCType = responseHasCType
230 , niBodyToSend = bodyToSend
235 type InteractionQueue = TVar (Seq SomeInteraction)
237 mkInteractionQueue ∷ IO InteractionQueue
238 mkInteractionQueue = newTVarIO (∅)
240 getCurrentDate ∷ IO Ascii
241 getCurrentDate = HTTP.toAscii <$> getCurrentTime