4 , ExistentialQuantification
9 module Network.HTTP.Lucu.Interaction
13 , SyntacticallyInvalidInteraction(..)
14 , mkSyntacticallyInvalidInteraction
16 , SemanticallyInvalidInteraction(..)
17 , mkSemanticallyInvalidInteraction
19 , NormalInteraction(..)
20 , InteractionState(..)
21 , ReceiveBodyRequest(..)
30 import Blaze.ByteString.Builder (Builder)
31 import Control.Applicative
32 import Control.Concurrent.STM
33 import Data.Ascii (Ascii)
34 import qualified Data.ByteString as Strict
35 import Data.Monoid.Unicode
36 import Data.Sequence (Seq)
38 import qualified Data.Time.HTTP as HTTP
41 import Network.HTTP.Lucu.Config
42 import Network.HTTP.Lucu.DefaultPage
43 import Network.HTTP.Lucu.Headers
44 import Network.HTTP.Lucu.Preprocess
45 import Network.HTTP.Lucu.Request
46 import Network.HTTP.Lucu.Response
51 class Typeable i ⇒ Interaction i where
52 toInteraction ∷ i → SomeInteraction
53 toInteraction = SomeInteraction
55 fromInteraction ∷ SomeInteraction → Maybe i
56 fromInteraction (SomeInteraction i) = cast i
59 = ∀i. Interaction i ⇒ SomeInteraction !i
62 instance Interaction SomeInteraction where
64 fromInteraction = Just
66 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
67 -- a syntactically valid 'Request'. The response code will always be
69 data SyntacticallyInvalidInteraction
71 syiResponse ∷ !Response
72 , syiBodyToSend ∷ !Builder
75 instance Interaction SyntacticallyInvalidInteraction
77 mkSyntacticallyInvalidInteraction ∷ Config
78 → IO SyntacticallyInvalidInteraction
79 mkSyntacticallyInvalidInteraction config@(Config {..})
80 = do date ← getCurrentDate
81 let res = setHeader "Server" cnfServerSoftware $
82 setHeader "Date" date $
83 setHeader "Content-Type" defaultPageContentType $
84 emptyResponse BadRequest
85 body = getDefaultPage config Nothing res
88 , syiBodyToSend = body
91 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
92 -- semantically valid 'Request'. The response code will always satisfy
94 data SemanticallyInvalidInteraction
97 , seiExpectedContinue ∷ !Bool
98 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
100 , seiResponse ∷ !Response
101 , seiWillChunkBody ∷ !Bool
102 , seiWillDiscardBody ∷ !Bool
103 , seiWillClose ∷ !Bool
104 , seiBodyToSend ∷ !Builder
107 instance Interaction SemanticallyInvalidInteraction
109 mkSemanticallyInvalidInteraction ∷ Config
111 → IO SemanticallyInvalidInteraction
112 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
113 = do date ← getCurrentDate
114 let res = setHeader "Server" cnfServerSoftware $
115 setHeader "Date" date $
116 setHeader "Content-Type" defaultPageContentType $
117 emptyResponse arInitialStatus
118 body = getDefaultPage config (Just arRequest) res
120 seiRequest = arRequest
121 , seiExpectedContinue = arExpectedContinue
122 , seiReqBodyLength = arReqBodyLength
125 , seiWillChunkBody = arWillChunkBody
126 , seiWillDiscardBody = arWillDiscardBody
127 , seiWillClose = arWillClose
128 , seiBodyToSend = body
131 -- |'NormalInteraction' is an 'Interaction' with a semantically
132 -- correct 'Request'.
133 data NormalInteraction
136 , niRemoteAddr ∷ !SockAddr
137 #if defined(HAVE_SSL)
138 , niRemoteCert ∷ !(Maybe X509)
140 , niRequest ∷ !Request
141 , niResourcePath ∷ ![Strict.ByteString]
142 , niExpectedContinue ∷ !Bool
143 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
145 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
146 , niReceivedBody ∷ !(TMVar Strict.ByteString)
148 , niResponse ∷ !(TVar Response)
149 , niSendContinue ∷ !(TMVar Bool)
150 , niWillChunkBody ∷ !Bool
151 , niWillDiscardBody ∷ !(TVar Bool)
152 , niWillClose ∷ !(TVar Bool)
153 , niResponseHasCType ∷ !(TVar Bool)
154 -- FIXME: use TBChan Builder (in stm-chans package)
155 , niBodyToSend ∷ !(TMVar Builder)
157 , niState ∷ !(TVar InteractionState)
160 instance Interaction NormalInteraction
162 data ReceiveBodyRequest
163 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
167 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
169 data InteractionState
175 deriving (Show, Eq, Ord, Enum)
177 mkNormalInteraction ∷ Config
179 #if defined(HAVE_SSL)
183 → [Strict.ByteString]
184 → IO NormalInteraction
185 #if defined(HAVE_SSL)
186 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
188 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
190 = do receiveBodyReq ← newEmptyTMVarIO
191 receivedBody ← newEmptyTMVarIO
193 response ← newTVarIO $ emptyResponse arInitialStatus
194 sendContinue ← newEmptyTMVarIO
195 willDiscardBody ← newTVarIO arWillDiscardBody
196 willClose ← newTVarIO arWillClose
197 responseHasCType ← newTVarIO False
198 bodyToSend ← newEmptyTMVarIO
200 state ← newTVarIO ExaminingRequest
204 , niRemoteAddr = remoteAddr
205 #if defined(HAVE_SSL)
206 , niRemoteCert = remoteCert
208 , niRequest = arRequest
209 , niResourcePath = rsrcPath
210 , niExpectedContinue = arExpectedContinue
211 , niReqBodyLength = arReqBodyLength
213 , niReceiveBodyReq = receiveBodyReq
214 , niReceivedBody = receivedBody
216 , niResponse = response
217 , niSendContinue = sendContinue
218 , niWillChunkBody = arWillChunkBody
219 , niWillDiscardBody = willDiscardBody
220 , niWillClose = willClose
221 , niResponseHasCType = responseHasCType
222 , niBodyToSend = bodyToSend
227 type InteractionQueue = TVar (Seq SomeInteraction)
229 mkInteractionQueue ∷ IO InteractionQueue
230 mkInteractionQueue = newTVarIO (∅)
232 getCurrentDate ∷ IO Ascii
233 getCurrentDate = HTTP.toAscii <$> getCurrentTime