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 → 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 ()
333 = do ni ← getInteraction
334 liftIO $ atomically $ go ni
336 go ∷ NormalInteraction → STM ()
338 = do state ← readTVar niState
339 when (state > DecidingHeader) $
340 fail "Too late to declare a response header field."
341 res ← readTVar niResponse
342 writeTVar niResponse $ H.setHeader name value res
343 when (name ≡ "Content-Type") $
344 writeTVar niResponseHasCType True
346 -- |@'deleteHeader' name@ deletes a response header @name@ if
347 -- any. This function is not intended to be used so frequently.
348 deleteHeader ∷ CIAscii → Resource ()
350 = do ni ← getInteraction
351 liftIO $ atomically $ go ni
353 go ∷ NormalInteraction → STM ()
355 = do state ← readTVar niState
356 when (state > DecidingHeader) $
357 fail "Too late to delete a response header field."
358 res ← readTVar niResponse
359 writeTVar niResponse $ H.deleteHeader name res
360 when (name ≡ "Content-Type") $
361 writeTVar niResponseHasCType False
363 -- |Run a 'Builder' to construct a chunk, and write it to the response
364 -- body. It can be safely applied to a 'Builder' producing an
365 -- infinitely long stream of octets.
367 -- Note that you must first declare the response header
368 -- \"Content-Type\" before applying this function. See
370 putBuilder ∷ Builder → Resource ()
372 = do ni ← getInteraction
373 liftIO $ atomically $ go ni
375 go ∷ NormalInteraction → STM ()
377 = do driftTo' ni SendingBody
378 hasCType ← readTVar niResponseHasCType
381 $ mkAbortion' InternalServerError
382 "putBuilder: Content-Type has not been set."
383 putTMVar niBodyToSend b
385 driftTo ∷ InteractionState → Resource ()
387 = do ni ← getInteraction
388 liftIO $ atomically $ driftTo' ni newState
390 driftTo' ∷ NormalInteraction → InteractionState → STM ()
391 driftTo' ni@(NI {..}) newState
392 = do oldState ← readTVar niState
395 driftFrom ∷ InteractionState → STM ()
397 | newState < oldState = throwStateError oldState newState
398 | newState ≡ oldState = return ()
400 = do let a = [oldState .. newState]
403 mapM_ (uncurry driftFromTo) c
404 writeTVar niState newState
406 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
407 throwStateError Done SendingBody
408 = fail "It makes no sense to output something after finishing outputs."
409 throwStateError old new
410 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
412 driftFromTo ∷ InteractionState → InteractionState → STM ()
413 driftFromTo ReceivingBody _
414 = putTMVar niReceiveBodyReq WasteAll
415 driftFromTo DecidingHeader _