3 , ExistentialQuantification
8 module Network.HTTP.Lucu.Interaction
12 , SyntacticallyInvalidInteraction(..)
13 , mkSyntacticallyInvalidInteraction
15 , SemanticallyInvalidInteraction(..)
16 , mkSemanticallyInvalidInteraction
18 , NormalInteraction(..)
19 , InteractionState(..)
20 , 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
49 class Typeable i ⇒ Interaction i where
50 toInteraction ∷ i → SomeInteraction
51 toInteraction = SomeInteraction
53 fromInteraction ∷ SomeInteraction → Maybe i
54 fromInteraction (SomeInteraction i) = cast i
57 = ∀i. Interaction i ⇒ SomeInteraction !i
60 instance Interaction SomeInteraction where
62 fromInteraction = Just
64 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
65 -- a syntactically valid 'Request'. The response code will always be
67 data SyntacticallyInvalidInteraction
69 syiResponse ∷ !Response
70 , syiBodyToSend ∷ !Builder
73 instance Interaction SyntacticallyInvalidInteraction
75 mkSyntacticallyInvalidInteraction ∷ Config
76 → IO SyntacticallyInvalidInteraction
77 mkSyntacticallyInvalidInteraction config@(Config {..})
78 = do date ← getCurrentDate
79 let res = setHeader "Server" cnfServerSoftware $
80 setHeader "Date" date $
81 setHeader "Content-Type" defaultPageContentType $
82 emptyResponse BadRequest
83 body = getDefaultPage config Nothing res
86 , syiBodyToSend = body
89 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
90 -- semantically valid 'Request'. The response code will always satisfy
92 data SemanticallyInvalidInteraction
95 , seiExpectedContinue ∷ !Bool
96 , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
98 , seiResponse ∷ !Response
99 , seiWillChunkBody ∷ !Bool
100 , seiWillDiscardBody ∷ !Bool
101 , seiWillClose ∷ !Bool
102 , seiBodyToSend ∷ !Builder
105 instance Interaction SemanticallyInvalidInteraction
107 mkSemanticallyInvalidInteraction ∷ Config
109 → IO SemanticallyInvalidInteraction
110 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
111 = do date ← getCurrentDate
112 let res = setHeader "Server" cnfServerSoftware $
113 setHeader "Date" date $
114 setHeader "Content-Type" defaultPageContentType $
115 emptyResponse arInitialStatus
116 body = getDefaultPage config (Just arRequest) res
118 seiRequest = arRequest
119 , seiExpectedContinue = arExpectedContinue
120 , seiReqBodyLength = arReqBodyLength
123 , seiWillChunkBody = arWillChunkBody
124 , seiWillDiscardBody = arWillDiscardBody
125 , seiWillClose = arWillClose
126 , seiBodyToSend = body
129 -- |'NormalInteraction' is an 'Interaction' with a semantically
130 -- correct 'Request'.
131 data NormalInteraction
134 , niRemoteAddr ∷ !SockAddr
135 , niRemoteCert ∷ !(Maybe X509)
136 , niRequest ∷ !Request
137 , niResourcePath ∷ ![Strict.ByteString]
138 , niExpectedContinue ∷ !Bool
139 , niReqBodyLength ∷ !(Maybe RequestBodyLength)
141 , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
142 , niReceivedBody ∷ !(TMVar Strict.ByteString)
144 , niResponse ∷ !(TVar Response)
145 , niSendContinue ∷ !(TMVar Bool)
146 , niWillChunkBody ∷ !Bool
147 , niWillDiscardBody ∷ !(TVar Bool)
148 , niWillClose ∷ !(TVar Bool)
149 , niResponseHasCType ∷ !(TVar Bool)
150 -- FIXME: use TBChan Builder (in stm-chans package)
151 , niBodyToSend ∷ !(TMVar Builder)
153 , niState ∷ !(TVar InteractionState)
156 instance Interaction NormalInteraction
158 data ReceiveBodyRequest
159 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
163 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
165 data InteractionState
171 deriving (Show, Eq, Ord, Enum)
173 mkNormalInteraction ∷ Config
177 → [Strict.ByteString]
178 → IO NormalInteraction
179 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
180 = do receiveBodyReq ← newEmptyTMVarIO
181 receivedBody ← newEmptyTMVarIO
183 response ← newTVarIO $ emptyResponse arInitialStatus
184 sendContinue ← newEmptyTMVarIO
185 willDiscardBody ← newTVarIO arWillDiscardBody
186 willClose ← newTVarIO arWillClose
187 responseHasCType ← newTVarIO False
188 bodyToSend ← newEmptyTMVarIO
190 state ← newTVarIO ExaminingRequest
194 , niRemoteAddr = remoteAddr
195 , niRemoteCert = remoteCert
196 , niRequest = arRequest
197 , niResourcePath = rsrcPath
198 , niExpectedContinue = arExpectedContinue
199 , niReqBodyLength = arReqBodyLength
201 , niReceiveBodyReq = receiveBodyReq
202 , niReceivedBody = receivedBody
204 , niResponse = response
205 , niSendContinue = sendContinue
206 , niWillChunkBody = arWillChunkBody
207 , niWillDiscardBody = willDiscardBody
208 , niWillClose = willClose
209 , niResponseHasCType = responseHasCType
210 , niBodyToSend = bodyToSend
215 type InteractionQueue = TVar (Seq SomeInteraction)
217 mkInteractionQueue ∷ IO InteractionQueue
218 mkInteractionQueue = newTVarIO (∅)
220 -- FIXME: Response.hs should provide setStatus ∷ sc → Response → Response
221 setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
222 setResponseStatus (NI {..}) sc
223 = do res ← readTVar niResponse
225 resStatus = fromStatusCode sc
227 writeTVar niResponse res'
229 getCurrentDate ∷ IO Ascii
230 getCurrentDate = HTTP.toAscii <$> getCurrentTime