3 , GeneralizedNewtypeDeriving
8 module Network.HTTP.Lucu.Resource.Internal
16 , getRemoteCertificate
31 import Blaze.ByteString.Builder (Builder)
32 import Control.Applicative
33 import Control.Concurrent
34 import Control.Concurrent.STM
35 import Control.Exception
36 import Control.Monad.IO.Class
37 import Control.Monad.Reader
38 import Control.Monad.Unicode
39 import Data.Ascii (Ascii, CIAscii)
40 import qualified Data.Ascii as A
41 import qualified Data.ByteString as Strict
45 import Data.Monoid.Unicode
46 import qualified Data.Text as T
47 import Network.HTTP.Lucu.Abortion
48 import Network.HTTP.Lucu.Abortion.Internal
49 import Network.HTTP.Lucu.Config
50 import Network.HTTP.Lucu.DefaultPage
51 import qualified Network.HTTP.Lucu.Headers as H
52 import Network.HTTP.Lucu.Interaction
53 import Network.HTTP.Lucu.Postprocess
54 import Network.HTTP.Lucu.Request
55 import Network.HTTP.Lucu.Response
58 import Prelude hiding (catch)
59 import Prelude.Unicode
62 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
66 unResource ∷ ReaderT NormalInteraction IO a
68 deriving (Applicative, Functor, Monad, MonadIO)
70 runResource ∷ Resource a → NormalInteraction → IO a
71 runResource = runReaderT ∘ unResource
73 -- |'ResourceDef' is basically a set of 'Resource' monads for each
75 data ResourceDef = ResourceDef {
76 -- |Whether to run a 'Resource' on a native thread (spawned by
77 -- 'forkOS') or to run it on a user thread (spanwed by
78 -- 'forkIO'). Generally you don't need to set this field to
80 resUsesNativeThread ∷ !Bool
81 -- | Whether to be greedy or not.
83 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
84 -- greedy resource at \/aaa\/bbb, it is always chosen even if
85 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
86 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
87 -- resources are like CGI scripts.
89 -- |A 'Resource' to be run when a GET request comes for the
90 -- resource path. If 'resGet' is Nothing, the system responds
91 -- \"405 Method Not Allowed\" for GET requests.
93 -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
94 -- that case 'putChunk' and such don't actually write a response
96 , resGet ∷ !(Maybe (Resource ()))
97 -- |A 'Resource' to be run when a HEAD request comes for the
98 -- resource path. If 'resHead' is Nothing, the system runs
99 -- 'resGet' instead. If 'resGet' is also Nothing, the system
100 -- responds \"405 Method Not Allowed\" for HEAD requests.
101 , resHead ∷ !(Maybe (Resource ()))
102 -- |A 'Resource' to be run when a POST request comes for the
103 -- resource path. If 'resPost' is Nothing, the system responds
104 -- \"405 Method Not Allowed\" for POST requests.
105 , resPost ∷ !(Maybe (Resource ()))
106 -- |A 'Resource' to be run when a PUT request comes for the
107 -- resource path. If 'resPut' is Nothing, the system responds
108 -- \"405 Method Not Allowed\" for PUT requests.
109 , resPut ∷ !(Maybe (Resource ()))
110 -- |A 'Resource' to be run when a DELETE request comes for the
111 -- resource path. If 'resDelete' is Nothing, the system responds
112 -- \"405 Method Not Allowed\" for DELETE requests.
113 , resDelete ∷ !(Maybe (Resource ()))
116 -- |'emptyResource' is a resource definition with no actual
117 -- handlers. You can construct a 'ResourceDef' by selectively
118 -- overriding 'emptyResource'. It is defined as follows:
121 -- emptyResource = ResourceDef {
122 -- resUsesNativeThread = False
123 -- , resIsGreedy = False
124 -- , resGet = Nothing
125 -- , resHead = Nothing
126 -- , resPost = Nothing
127 -- , resPut = Nothing
128 -- , resDelete = Nothing
131 emptyResource ∷ ResourceDef
132 emptyResource = ResourceDef {
133 resUsesNativeThread = False
134 , resIsGreedy = False
139 , resDelete = Nothing
142 spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
143 spawnResource (ResourceDef {..}) ni@(NI {..})
144 = fork $ run `catch` processException
146 fork ∷ IO () → IO ThreadId
147 fork | resUsesNativeThread = forkOS
151 run = flip runResource ni $
153 fromMaybe notAllowed $ rsrc req
156 rsrc ∷ Request → Maybe (Resource ())
158 = case reqMethod req of
160 HEAD → case resHead of
166 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
168 notAllowed ∷ Resource ()
169 notAllowed = do setStatus MethodNotAllowed
173 $ intersperse (A.toAsciiBuilder ", ")
174 $ map A.toAsciiBuilder allowedMethods
176 allowedMethods ∷ [Ascii]
177 allowedMethods = nub $ concat [ methods resGet ["GET"]
178 , methods resHead ["GET", "HEAD"]
179 , methods resPost ["POST"]
180 , methods resPut ["PUT"]
181 , methods resDelete ["DELETE"]
184 methods ∷ Maybe a → [Ascii] → [Ascii]
189 toAbortion ∷ SomeException → Abortion
191 = case fromException e of
192 Just abortion → abortion
193 Nothing → mkAbortion' InternalServerError $ T.pack $ show e
195 processException ∷ SomeException → IO ()
197 = do let abo = toAbortion exc
198 state ← atomically $ readTVar niState
199 res ← atomically $ readTVar niResponse
200 if state ≤ DecidingHeader then
201 -- We still have a chance to reflect this abortion
202 -- in the response. Hooray!
203 flip runResource ni $
204 do setStatus $ aboStatus abo
205 mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
206 setHeader "Content-Type" defaultPageContentType
207 deleteHeader "Content-Encoding"
208 putBuilder $ abortPage niConfig (Just niRequest) res abo
210 when (cnfDumpTooLateAbortionToStderr niConfig)
212 runResource (driftTo Done) ni
214 dumpAbortion ∷ Abortion → IO ()
217 $ concat [ "Lucu: an exception occured after "
218 , "sending the response header to the client:\n"
219 , " ", show abo, "\n"
222 getInteraction ∷ Resource NormalInteraction
223 getInteraction = Resource ask
225 -- |Get the 'Config' value for this httpd.
226 getConfig ∷ Resource Config
227 getConfig = niConfig <$> getInteraction
229 -- |Get the 'SockAddr' of the remote host.
230 getRemoteAddr ∷ Resource SockAddr
231 getRemoteAddr = niRemoteAddr <$> getInteraction
233 -- | Return the X.509 certificate of the client, or 'Nothing' if:
235 -- * This request didn't came through an SSL stream.
237 -- * The client didn't send us its certificate.
239 -- * The 'OpenSSL.Session.VerificationMode' of
240 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
241 -- 'OpenSSL.Session.VerifyPeer'.
242 getRemoteCertificate ∷ Resource (Maybe X509)
243 getRemoteCertificate = niRemoteCert <$> getInteraction
245 -- |Return the 'Request' value representing the request header. You
246 -- usually don't need to call this function directly.
247 getRequest ∷ Resource Request
248 getRequest = niRequest <$> getInteraction
250 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
251 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
252 -- action is the exact path in the tree even when the 'ResourceDef' is
257 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
258 -- > in runHttpd defaultConfig tree []
260 -- > resFoo = emptyResource {
261 -- > resIsGreedy = True
262 -- > , resGet = Just $ do requestURI <- getRequestURI
263 -- > resourcePath <- getResourcePath
264 -- > pathInfo <- getPathInfo
265 -- > -- uriPath requestURI == "/foo/bar/baz"
266 -- > -- resourcePath == ["foo"]
267 -- > -- pathInfo == ["bar", "baz"]
270 getResourcePath ∷ Resource [Strict.ByteString]
271 getResourcePath = niResourcePath <$> getInteraction
273 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
274 -- bytes. You can incrementally read the request body by repeatedly
275 -- calling this function. If there is nothing to be read anymore,
276 -- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
277 -- the /Deciding Header/ state.
278 getChunk ∷ Int → Resource Strict.ByteString
279 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
281 getChunk' ∷ Int → Resource Strict.ByteString
283 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
285 | otherwise = do req ← getRequest
286 if reqMustHaveBody req then
287 askForInput =≪ getInteraction
289 driftTo DecidingHeader *> return (∅)
291 askForInput ∷ NormalInteraction → Resource Strict.ByteString
292 askForInput (NI {..})
293 = do -- Ask the RequestReader to get a chunk.
295 $ putTMVar niReceiveBodyReq (ReceiveBody n)
296 -- Then wait for a reply.
299 $ takeTMVar niReceivedBody
300 -- Have we got an EOF?
301 when (Strict.null chunk)
302 $ driftTo DecidingHeader
305 -- |Declare the response status code. If you don't call this function,
306 -- the status code will be defaulted to \"200 OK\".
307 setStatus ∷ StatusCode sc ⇒ sc → Resource ()
309 = do ni ← getInteraction
311 $ do state ← readTVar $ niState ni
312 when (state > DecidingHeader)
313 $ fail "Too late to declare the response status."
314 setResponseStatus ni sc
316 -- |@'setHeader' name value@ declares the value of the response header
317 -- @name@ as @value@. Note that this function is not intended to be
318 -- used so frequently: there should be specialised functions like
319 -- 'setContentType' for every common headers.
321 -- Some important headers (especially \"Content-Length\" and
322 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
323 -- the system not to corrupt the interaction with client at the
324 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
325 -- the connection alive, without this manipulation it will be a
326 -- catastrophe when we send a header \"Content-Length: 10\" and
327 -- actually send a body of 20 bytes long to the remote peer. In this
328 -- case the client shall only accept the first 10 bytes of response
329 -- body and thinks that the residual 10 bytes is a part of the header
330 -- of the next response.
331 setHeader ∷ CIAscii → Ascii → Resource ()
332 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
334 go ∷ NormalInteraction → STM ()
336 = do state ← readTVar niState
337 when (state > DecidingHeader) $
338 fail "Too late to declare a response header field."
339 res ← readTVar niResponse
340 writeTVar niResponse $ H.setHeader name value res
341 when (name ≡ "Content-Type") $
342 writeTVar niResponseHasCType True
344 -- |@'deleteHeader' name@ deletes a response header @name@ if
345 -- any. This function is not intended to be used so frequently.
346 deleteHeader ∷ CIAscii → Resource ()
347 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
349 go ∷ NormalInteraction → STM ()
351 = do state ← readTVar niState
352 when (state > DecidingHeader) $
353 fail "Too late to delete a response header field."
354 res ← readTVar niResponse
355 writeTVar niResponse $ H.deleteHeader name res
356 when (name ≡ "Content-Type") $
357 writeTVar niResponseHasCType False
359 -- |Run a 'Builder' to construct a chunk, and write it to the response
360 -- body. It can be safely applied to a 'Builder' producing an
361 -- infinitely long stream of octets.
363 -- Note that you must first declare the response header
364 -- \"Content-Type\" before applying this function. See:
366 putBuilder ∷ Builder → Resource ()
367 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
369 go ∷ NormalInteraction → STM ()
371 = do driftTo' ni SendingBody
372 hasCType ← readTVar niResponseHasCType
375 $ mkAbortion' InternalServerError
376 "putBuilder: Content-Type has not been set."
377 putTMVar niBodyToSend b
379 driftTo ∷ InteractionState → Resource ()
380 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
382 driftTo' ∷ NormalInteraction → InteractionState → STM ()
383 driftTo' ni@(NI {..}) newState
384 = do oldState ← readTVar niState
387 driftFrom ∷ InteractionState → STM ()
389 | newState < oldState = throwStateError oldState newState
390 | newState ≡ oldState = return ()
392 = do let a = [oldState .. newState]
395 mapM_ (uncurry driftFromTo) c
396 writeTVar niState newState
398 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
399 throwStateError Done SendingBody
400 = fail "It makes no sense to output something after finishing outputs."
401 throwStateError old new
402 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
404 driftFromTo ∷ InteractionState → InteractionState → STM ()
405 driftFromTo ReceivingBody _
406 = putTMVar niReceiveBodyReq WasteAll
407 driftFromTo DecidingHeader _