4 , GeneralizedNewtypeDeriving
9 module Network.HTTP.Lucu.Resource.Internal
18 , getRemoteCertificate
34 import Blaze.ByteString.Builder (Builder)
35 import Control.Applicative
36 import Control.Concurrent
37 import Control.Concurrent.STM
38 import Control.Exception
39 import Control.Monad hiding (mapM_)
40 import Control.Monad.IO.Class
41 import Control.Monad.Reader (ReaderT, runReaderT, ask)
42 import Control.Monad.Unicode
43 import Data.Ascii (Ascii, CIAscii)
44 import qualified Data.Ascii as A
45 import qualified Data.ByteString as Strict
46 import Data.Collections
47 import Data.List (intersperse, nub)
50 import Data.Monoid.Unicode
51 import qualified Data.Text as T
52 import Network.HTTP.Lucu.Abortion
53 import Network.HTTP.Lucu.Abortion.Internal
54 import Network.HTTP.Lucu.Config
55 import Network.HTTP.Lucu.DefaultPage
56 import qualified Network.HTTP.Lucu.Headers as H
57 import Network.HTTP.Lucu.Interaction
58 import Network.HTTP.Lucu.Postprocess
59 import Network.HTTP.Lucu.Request
60 import Network.HTTP.Lucu.Response
65 import Prelude hiding (catch, concat, mapM_, tail)
66 import Prelude.Unicode
69 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
73 unResource ∷ ReaderT NormalInteraction IO a
75 deriving (Applicative, Functor, Monad, MonadIO)
77 runResource ∷ Resource a → NormalInteraction → IO a
78 runResource = runReaderT ∘ unResource
80 -- |'ResourceDef' is basically a set of 'Resource' monads for each
82 data ResourceDef = ResourceDef {
83 -- |Whether to run a 'Resource' on a native thread (spawned by
84 -- 'forkOS') or to run it on a user thread (spanwed by
85 -- 'forkIO'). Generally you don't need to set this field to
87 resUsesNativeThread ∷ !Bool
88 -- | Whether to be greedy or not.
90 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
91 -- greedy resource at \/aaa\/bbb, it is always chosen even if
92 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
93 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
94 -- resources are like CGI scripts.
96 -- |A 'Resource' to be run when a GET request comes for the
97 -- resource path. If 'resGet' is Nothing, the system responds
98 -- \"405 Method Not Allowed\" for GET requests.
100 -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
101 -- that case 'putChunk' and such don't actually write a response
103 , resGet ∷ !(Maybe (Resource ()))
104 -- |A 'Resource' to be run when a HEAD request comes for the
105 -- resource path. If 'resHead' is Nothing, the system runs
106 -- 'resGet' instead. If 'resGet' is also Nothing, the system
107 -- responds \"405 Method Not Allowed\" for HEAD requests.
108 , resHead ∷ !(Maybe (Resource ()))
109 -- |A 'Resource' to be run when a POST request comes for the
110 -- resource path. If 'resPost' is Nothing, the system responds
111 -- \"405 Method Not Allowed\" for POST requests.
112 , resPost ∷ !(Maybe (Resource ()))
113 -- |A 'Resource' to be run when a PUT request comes for the
114 -- resource path. If 'resPut' is Nothing, the system responds
115 -- \"405 Method Not Allowed\" for PUT requests.
116 , resPut ∷ !(Maybe (Resource ()))
117 -- |A 'Resource' to be run when a DELETE request comes for the
118 -- resource path. If 'resDelete' is Nothing, the system responds
119 -- \"405 Method Not Allowed\" for DELETE requests.
120 , resDelete ∷ !(Maybe (Resource ()))
123 -- |'emptyResource' is a resource definition with no actual
124 -- handlers. You can construct a 'ResourceDef' by selectively
125 -- overriding 'emptyResource'. It is defined as follows:
128 -- emptyResource = ResourceDef {
129 -- resUsesNativeThread = False
130 -- , resIsGreedy = False
131 -- , resGet = Nothing
132 -- , resHead = Nothing
133 -- , resPost = Nothing
134 -- , resPut = Nothing
135 -- , resDelete = Nothing
138 emptyResource ∷ ResourceDef
139 emptyResource = ResourceDef {
140 resUsesNativeThread = False
141 , resIsGreedy = False
146 , resDelete = Nothing
149 spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
150 spawnResource (ResourceDef {..}) ni@(NI {..})
151 = fork $ run `catch` processException
153 fork ∷ IO () → IO ThreadId
154 fork | resUsesNativeThread = forkOS
158 run = flip runResource ni $
160 fromMaybe notAllowed $ rsrc req
163 rsrc ∷ Request → Maybe (Resource ())
165 = case reqMethod req of
167 HEAD → case resHead of
173 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
175 notAllowed ∷ Resource ()
176 notAllowed = do setStatus MethodNotAllowed
180 $ intersperse (A.toAsciiBuilder ", ")
181 $ map A.toAsciiBuilder allowedMethods
183 allowedMethods ∷ [Ascii]
184 allowedMethods = nub $ concat [ methods resGet ["GET"]
185 , methods resHead ["GET", "HEAD"]
186 , methods resPost ["POST"]
187 , methods resPut ["PUT"]
188 , methods resDelete ["DELETE"]
191 methods ∷ Maybe a → [Ascii] → [Ascii]
196 toAbortion ∷ SomeException → Abortion
198 = case fromException e of
199 Just abortion → abortion
200 Nothing → mkAbortion' InternalServerError $ T.pack $ show e
202 processException ∷ SomeException → IO ()
204 = do let abo = toAbortion exc
205 state ← atomically $ readTVar niState
206 res ← atomically $ readTVar niResponse
207 if state ≤ DecidingHeader then
208 -- We still have a chance to reflect this abortion
209 -- in the response. Hooray!
210 flip runResource ni $
211 do setStatus $ aboStatus abo
212 mapM_ (uncurry setHeader) (aboHeaders abo)
213 setHeader "Content-Type" defaultPageContentType
214 deleteHeader "Content-Encoding"
215 putBuilder $ abortPage niConfig (Just niRequest) res abo
217 when (cnfDumpTooLateAbortionToStderr niConfig)
219 runResource (driftTo Done) ni
221 dumpAbortion ∷ Abortion → IO ()
224 $ concat [ "Lucu: an exception occured after "
225 , "sending the response header to the client:\n"
226 , " ", show abo, "\n"
229 getInteraction ∷ Resource NormalInteraction
230 getInteraction = Resource ask
232 -- |Get the 'Config' value for this httpd.
233 getConfig ∷ Resource Config
234 getConfig = niConfig <$> getInteraction
236 -- |Get the 'SockAddr' of the remote host.
237 getRemoteAddr ∷ Resource SockAddr
238 getRemoteAddr = niRemoteAddr <$> getInteraction
240 #if defined(HAVE_SSL)
241 -- | Return the X.509 certificate of the client, or 'Nothing' if:
243 -- * This request didn't came through an SSL stream.
245 -- * The client didn't send us its certificate.
247 -- * The 'OpenSSL.Session.VerificationMode' of
248 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
249 -- 'OpenSSL.Session.VerifyPeer'.
250 getRemoteCertificate ∷ Resource (Maybe X509)
251 getRemoteCertificate = niRemoteCert <$> getInteraction
254 -- |Return the 'Request' value representing the request header. You
255 -- usually don't need to call this function directly.
256 getRequest ∷ Resource Request
257 getRequest = niRequest <$> getInteraction
259 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
260 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
261 -- action is the exact path in the tree even when the 'ResourceDef' is
266 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
267 -- > in runHttpd defaultConfig tree []
269 -- > resFoo = emptyResource {
270 -- > resIsGreedy = True
271 -- > , resGet = Just $ do requestURI <- getRequestURI
272 -- > resourcePath <- getResourcePath
273 -- > pathInfo <- getPathInfo
274 -- > -- uriPath requestURI == "/foo/bar/baz"
275 -- > -- resourcePath == ["foo"]
276 -- > -- pathInfo == ["bar", "baz"]
279 getResourcePath ∷ Resource [Strict.ByteString]
280 getResourcePath = niResourcePath <$> getInteraction
282 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
283 -- bytes. You can incrementally read the request body by repeatedly
284 -- calling this function. If there is nothing to be read anymore,
285 -- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
286 -- the /Deciding Header/ state.
287 getChunk ∷ Int → Resource Strict.ByteString
288 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
290 getChunk' ∷ Int → Resource Strict.ByteString
292 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
294 | otherwise = do req ← getRequest
295 if reqMustHaveBody req then
296 askForInput =≪ getInteraction
298 driftTo DecidingHeader *> return (∅)
300 askForInput ∷ NormalInteraction → Resource Strict.ByteString
301 askForInput (NI {..})
302 = do -- Ask the RequestReader to get a chunk.
304 $ putTMVar niReceiveBodyReq (ReceiveBody n)
305 -- Then wait for a reply.
308 $ takeTMVar niReceivedBody
309 -- Have we got an EOF?
310 when (Strict.null chunk)
311 $ driftTo DecidingHeader
314 -- |Declare the response status code. If you don't call this function,
315 -- the status code will be defaulted to \"200 OK\".
316 setStatus ∷ StatusCode sc ⇒ sc → Resource ()
318 = do ni ← getInteraction
320 $ do state ← readTVar $ niState ni
321 when (state > DecidingHeader)
322 $ fail "Too late to declare the response status."
323 res ← readTVar $ niResponse ni
324 writeTVar (niResponse ni) $ setStatusCode sc res
326 -- |@'setHeader' name value@ declares the value of the response header
327 -- @name@ as @value@. Note that this function is not intended to be
328 -- used so frequently: there should be specialised functions like
329 -- 'setContentType' for every common headers.
331 -- Some important headers (especially \"Content-Length\" and
332 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
333 -- the system not to corrupt the interaction with client at the
334 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
335 -- the connection alive, without this manipulation it will be a
336 -- catastrophe when we send a header \"Content-Length: 10\" and
337 -- actually send a body of 20 bytes long to the remote peer. In this
338 -- case the client shall only accept the first 10 bytes of response
339 -- body and thinks that the residual 10 bytes is a part of the header
340 -- of the next response.
341 setHeader ∷ CIAscii → Ascii → Resource ()
342 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
344 go ∷ NormalInteraction → STM ()
346 = do state ← readTVar niState
347 when (state > DecidingHeader) $
348 fail "Too late to declare a response header field."
349 res ← readTVar niResponse
350 writeTVar niResponse $ H.setHeader name value res
351 when (name ≡ "Content-Type") $
352 writeTVar niResponseHasCType True
354 -- |@'deleteHeader' name@ deletes a response header @name@ if
355 -- any. This function is not intended to be used so frequently.
356 deleteHeader ∷ CIAscii → Resource ()
357 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
359 go ∷ NormalInteraction → STM ()
361 = do state ← readTVar niState
362 when (state > DecidingHeader) $
363 fail "Too late to delete a response header field."
364 res ← readTVar niResponse
365 writeTVar niResponse $ H.deleteHeader name res
366 when (name ≡ "Content-Type") $
367 writeTVar niResponseHasCType False
369 -- |Run a 'Builder' to construct a chunk, and write it to the response
370 -- body. It can be safely applied to a 'Builder' producing an
371 -- infinitely long stream of octets.
373 -- Note that you must first declare the response header
374 -- \"Content-Type\" before applying this function. See:
376 putBuilder ∷ Builder → Resource ()
377 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
379 -- FIXME: should see if resCanHaveBody.
380 go ∷ NormalInteraction → STM ()
382 = do driftTo' ni SendingBody
383 hasCType ← readTVar niResponseHasCType
386 $ mkAbortion' InternalServerError
387 "putBuilder: Content-Type has not been set."
388 putTMVar niBodyToSend b
390 driftTo ∷ InteractionState → Resource ()
391 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
393 driftTo' ∷ NormalInteraction → InteractionState → STM ()
394 driftTo' ni@(NI {..}) newState
395 = do oldState ← readTVar niState
398 driftFrom ∷ InteractionState → STM ()
400 | newState < oldState = throwStateError oldState newState
401 | newState ≡ oldState = return ()
403 = do let a = [oldState .. newState]
406 mapM_ (uncurry driftFromTo) c
407 writeTVar niState newState
409 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
410 throwStateError Done SendingBody
411 = fail "It makes no sense to output something after finishing outputs."
412 throwStateError old new
413 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
415 driftFromTo ∷ InteractionState → InteractionState → STM ()
416 driftFromTo ReceivingBody _
417 = putTMVar niReceiveBodyReq WasteAll
418 driftFromTo DecidingHeader _