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 , niBodyToSend ∷ !(TMVar Builder)
152 , niState ∷ !(TVar InteractionState)
155 instance Interaction NormalInteraction
157 data ReceiveBodyRequest
158 = ReceiveBody !Int -- ^ Maximum number of octets to receive.
162 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
164 data InteractionState
170 deriving (Show, Eq, Ord, Enum)
172 mkNormalInteraction ∷ Config
176 → [Strict.ByteString]
177 → IO NormalInteraction
178 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
179 = do receiveBodyReq ← newEmptyTMVarIO
180 receivedBody ← newEmptyTMVarIO
182 response ← newTVarIO $ emptyResponse arInitialStatus
183 sendContinue ← newEmptyTMVarIO
184 willDiscardBody ← newTVarIO arWillDiscardBody
185 willClose ← newTVarIO arWillClose
186 responseHasCType ← newTVarIO False
187 bodyToSend ← newEmptyTMVarIO
189 state ← newTVarIO ExaminingRequest
193 , niRemoteAddr = remoteAddr
194 , niRemoteCert = remoteCert
195 , niRequest = arRequest
196 , niResourcePath = rsrcPath
197 , niExpectedContinue = arExpectedContinue
198 , niReqBodyLength = arReqBodyLength
200 , niReceiveBodyReq = receiveBodyReq
201 , niReceivedBody = receivedBody
203 , niResponse = response
204 , niSendContinue = sendContinue
205 , niWillChunkBody = arWillChunkBody
206 , niWillDiscardBody = willDiscardBody
207 , niWillClose = willClose
208 , niResponseHasCType = responseHasCType
209 , niBodyToSend = bodyToSend
214 type InteractionQueue = TVar (Seq SomeInteraction)
216 mkInteractionQueue ∷ IO InteractionQueue
217 mkInteractionQueue = newTVarIO (∅)
219 setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
220 setResponseStatus (NI {..}) sc
221 = do res ← readTVar niResponse
223 resStatus = fromStatusCode sc
225 writeTVar niResponse res'
227 getCurrentDate ∷ IO Ascii
228 getCurrentDate = HTTP.toAscii <$> getCurrentTime