4 , ExistentialQuantification
9 module Network.HTTP.Lucu.Interaction
13 , SyntacticallyInvalidInteraction(..)
14 , mkSyntacticallyInvalidInteraction
16 , SemanticallyInvalidInteraction(..)
17 , mkSemanticallyInvalidInteraction
19 , NormalInteraction(..)
20 , InteractionState(..)
21 , 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 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
68 -- a syntactically valid 'Request'. The response code will always be
70 data SyntacticallyInvalidInteraction
72 syiResponse ∷ !Response
73 , syiBodyToSend ∷ !Builder
76 instance Interaction SyntacticallyInvalidInteraction
78 mkSyntacticallyInvalidInteraction ∷ Config
79 → IO SyntacticallyInvalidInteraction
80 mkSyntacticallyInvalidInteraction config@(Config {..})
81 = do date ← getCurrentDate
82 let res = setHeader "Server" cnfServerSoftware $
83 setHeader "Date" date $
84 setHeader "Content-Type" defaultPageContentType $
85 emptyResponse BadRequest
86 body = getDefaultPage config Nothing res
89 , syiBodyToSend = body
92 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
93 -- semantically valid 'Request'. The response code will always satisfy
95 data SemanticallyInvalidInteraction
98 , seiExpectedContinue ∷ !Bool
99 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
101 , seiResponse ∷ !Response
102 , seiWillChunkBody ∷ !Bool
103 , seiWillDiscardBody ∷ !Bool
104 , seiWillClose ∷ !Bool
105 , seiBodyToSend ∷ !Builder
108 instance Interaction SemanticallyInvalidInteraction
110 mkSemanticallyInvalidInteraction ∷ Config
112 → IO SemanticallyInvalidInteraction
113 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
114 = do date ← getCurrentDate
115 let res = setHeader "Server" cnfServerSoftware $
116 setHeader "Date" date $
117 setHeader "Content-Type" defaultPageContentType $
118 emptyResponse arInitialStatus
119 body = getDefaultPage config (Just arRequest) res
121 seiRequest = arRequest
122 , seiExpectedContinue = arExpectedContinue
123 , seiReqBodyLength = arReqBodyLength
126 , seiWillChunkBody = arWillChunkBody
127 , seiWillDiscardBody = arWillDiscardBody
128 , seiWillClose = arWillClose
129 , seiBodyToSend = body
132 -- |'NormalInteraction' is an 'Interaction' with a semantically
133 -- correct 'Request'.
134 data NormalInteraction
137 , niRemoteAddr ∷ !SockAddr
138 #if defined(HAVE_SSL)
139 , niRemoteCert ∷ !(Maybe X509)
141 , niRequest ∷ !Request
142 , niResourcePath ∷ ![Strict.ByteString]
143 , niExpectedContinue ∷ !Bool
144 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
146 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
147 , niReceivedBody ∷ !(TMVar Strict.ByteString)
149 , niResponse ∷ !(TVar Response)
150 , niSendContinue ∷ !(TMVar Bool)
151 , niWillChunkBody ∷ !Bool
152 , niWillDiscardBody ∷ !(TVar Bool)
153 , niWillClose ∷ !(TVar Bool)
154 , niResponseHasCType ∷ !(TVar Bool)
155 -- FIXME: use TBChan Builder (in stm-chans package)
156 , niBodyToSend ∷ !(TMVar Builder)
158 , niState ∷ !(TVar InteractionState)
161 instance Interaction NormalInteraction
163 data ReceiveBodyRequest
164 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
168 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
170 data InteractionState
176 deriving (Show, Eq, Ord, Enum)
178 mkNormalInteraction ∷ Config
180 #if defined(HAVE_SSL)
184 → [Strict.ByteString]
185 → IO NormalInteraction
186 #if defined(HAVE_SSL)
187 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
189 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
191 = do receiveBodyReq ← newEmptyTMVarIO
192 receivedBody ← newEmptyTMVarIO
194 response ← newTVarIO $ emptyResponse arInitialStatus
195 sendContinue ← newEmptyTMVarIO
196 willDiscardBody ← newTVarIO arWillDiscardBody
197 willClose ← newTVarIO arWillClose
198 responseHasCType ← newTVarIO False
199 bodyToSend ← newEmptyTMVarIO
201 state ← newTVarIO ExaminingRequest
205 , niRemoteAddr = remoteAddr
206 #if defined(HAVE_SSL)
207 , niRemoteCert = remoteCert
209 , niRequest = arRequest
210 , niResourcePath = rsrcPath
211 , niExpectedContinue = arExpectedContinue
212 , niReqBodyLength = arReqBodyLength
214 , niReceiveBodyReq = receiveBodyReq
215 , niReceivedBody = receivedBody
217 , niResponse = response
218 , niSendContinue = sendContinue
219 , niWillChunkBody = arWillChunkBody
220 , niWillDiscardBody = willDiscardBody
221 , niWillClose = willClose
222 , niResponseHasCType = responseHasCType
223 , niBodyToSend = bodyToSend
228 type InteractionQueue = TVar (Seq SomeInteraction)
230 mkInteractionQueue ∷ IO InteractionQueue
231 mkInteractionQueue = newTVarIO (∅)
233 -- FIXME: Response.hs should provide setStatus ∷ sc → Response → Response
234 setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
235 setResponseStatus (NI {..}) sc
236 = do res ← readTVar niResponse
238 resStatus = fromStatusCode sc
240 writeTVar niResponse res'
242 getCurrentDate ∷ IO Ascii
243 getCurrentDate = HTTP.toAscii <$> getCurrentTime