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 , seiWillClose ∷ !Bool
115 , seiBodyToSend ∷ !Builder
118 instance Interaction SemanticallyInvalidInteraction
120 mkSemanticallyInvalidInteraction ∷ Config
122 → IO SemanticallyInvalidInteraction
123 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
124 = do date ← getCurrentDate
125 let res = setHeader "Server" cnfServerSoftware $
126 setHeader "Date" date $
127 setHeader "Content-Type" defaultPageContentType $
129 then setHeader "Transfer-Encoding" "chunked"
133 then setHeader "Connection" "close"
136 emptyResponse arInitialStatus
137 body = defaultPageForResponse config (Just arRequest) res
139 seiRequest = arRequest
140 , seiExpectedContinue = arExpectedContinue
141 , seiReqBodyLength = arReqBodyLength
144 , seiWillChunkBody = arWillChunkBody
145 , seiWillClose = arWillClose
146 , seiBodyToSend = body
149 -- |'NormalInteraction' is an 'Interaction' with a semantically
150 -- correct 'Request'.
151 data NormalInteraction
154 , niRemoteAddr ∷ !SockAddr
155 #if defined(HAVE_SSL)
156 , niRemoteCert ∷ !(Maybe X509)
158 , niRequest ∷ !Request
159 , niResourcePath ∷ !Path
160 , niExpectedContinue ∷ !Bool
161 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
163 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
164 , niReceivedBody ∷ !(TMVar ByteString)
166 , niResponse ∷ !(TVar Response)
167 , niSendContinue ∷ !(TMVar Bool)
168 , niWillChunkBody ∷ !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 willClose ← newTVarIO arWillClose
213 responseHasCType ← newTVarIO False
214 bodyToSend ← newEmptyTMVarIO
216 state ← newTVarIO ExaminingRequest
220 , niRemoteAddr = remoteAddr
221 #if defined(HAVE_SSL)
222 , niRemoteCert = remoteCert
224 , niRequest = arRequest
225 , niResourcePath = rsrcPath
226 , niExpectedContinue = arExpectedContinue
227 , niReqBodyLength = arReqBodyLength
229 , niReceiveBodyReq = receiveBodyReq
230 , niReceivedBody = receivedBody
232 , niResponse = response
233 , niSendContinue = sendContinue
234 , niWillChunkBody = arWillChunkBody
235 , niWillClose = willClose
236 , niResponseHasCType = responseHasCType
237 , niBodyToSend = bodyToSend
242 type InteractionQueue = TVar (Seq SomeInteraction)
244 mkInteractionQueue ∷ IO InteractionQueue
245 {-# INLINE mkInteractionQueue #-}
246 mkInteractionQueue = newTVarIO (∅)
248 getCurrentDate ∷ IO Ascii
249 {-# INLINE getCurrentDate #-}
250 getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime