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 Data.ByteString (ByteString)
46 import qualified Data.ByteString as BS
47 import Data.Collections
48 import Data.List (intersperse, nub)
51 import Data.Monoid.Unicode
52 import qualified Data.Text as T
53 import Network.HTTP.Lucu.Abortion
54 import Network.HTTP.Lucu.Abortion.Internal
55 import Network.HTTP.Lucu.Config
56 import Network.HTTP.Lucu.DefaultPage
57 import qualified Network.HTTP.Lucu.Headers as H
58 import Network.HTTP.Lucu.Interaction
59 import Network.HTTP.Lucu.Postprocess
60 import Network.HTTP.Lucu.Request
61 import Network.HTTP.Lucu.Response
62 import Network.HTTP.Lucu.Utils
67 import Prelude hiding (catch, concat, mapM_, tail)
68 import Prelude.Unicode
71 -- |The resource monad. This monad implements 'MonadIO' so it can do
75 unRsrc ∷ ReaderT NormalInteraction IO a
77 deriving (Applicative, Functor, Monad, MonadIO)
79 runRsrc ∷ Rsrc a → NormalInteraction → IO a
80 runRsrc = runReaderT ∘ unRsrc
82 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
84 data Resource = Resource {
85 -- | Whether to be greedy or not.
87 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
88 -- greedy resource at \/aaa\/bbb, it is always chosen even if
89 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
90 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
91 -- resources are like CGI scripts.
93 -- |A 'Rsrc' to be run when a GET request comes for the
94 -- resource path. If 'resGet' is Nothing, the system responds
95 -- \"405 Method Not Allowed\" for GET requests.
97 -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
98 -- that case 'putChunk' and such don't actually write a response
100 , resGet ∷ !(Maybe (Rsrc ()))
101 -- |A 'Rsrc' to be run when a HEAD request comes for the
102 -- resource path. If 'resHead' is Nothing, the system runs
103 -- 'resGet' instead. If 'resGet' is also Nothing, the system
104 -- responds \"405 Method Not Allowed\" for HEAD requests.
105 , resHead ∷ !(Maybe (Rsrc ()))
106 -- |A 'Rsrc' to be run when a POST request comes for the
107 -- resource path. If 'resPost' is Nothing, the system responds
108 -- \"405 Method Not Allowed\" for POST requests.
109 , resPost ∷ !(Maybe (Rsrc ()))
110 -- |A 'Rsrc' to be run when a PUT request comes for the
111 -- resource path. If 'resPut' is Nothing, the system responds
112 -- \"405 Method Not Allowed\" for PUT requests.
113 , resPut ∷ !(Maybe (Rsrc ()))
114 -- |A 'Rsrc' to be run when a DELETE request comes for the
115 -- resource path. If 'resDelete' is Nothing, the system responds
116 -- \"405 Method Not Allowed\" for DELETE requests.
117 , resDelete ∷ !(Maybe (Rsrc ()))
120 -- |'emptyResource' is a resource definition with no actual
121 -- handlers. You can construct a 'Resource' by selectively overriding
122 -- 'emptyResource'. It is defined as follows:
125 -- emptyResource = Resource {
126 -- resUsesNativeThread = False
127 -- , resIsGreedy = False
128 -- , resGet = Nothing
129 -- , resHead = Nothing
130 -- , resPost = Nothing
131 -- , resPut = Nothing
132 -- , resDelete = Nothing
135 emptyResource ∷ Resource
136 emptyResource = Resource {
142 , resDelete = Nothing
145 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
146 spawnRsrc (Resource {..}) ni@(NI {..})
147 = forkIO $ run `catch` processException
150 run = flip runRsrc ni $
152 fromMaybe notAllowed $ rsrc req
155 rsrc ∷ Request → Maybe (Rsrc ())
157 = case reqMethod req of
159 HEAD → case resHead of
165 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
168 notAllowed = do setStatus MethodNotAllowed
172 $ intersperse (A.toAsciiBuilder ", ")
173 $ map A.toAsciiBuilder allowedMethods
175 allowedMethods ∷ [Ascii]
176 allowedMethods = nub $ concat [ methods resGet ["GET"]
177 , methods resHead ["GET", "HEAD"]
178 , methods resPost ["POST"]
179 , methods resPut ["PUT"]
180 , methods resDelete ["DELETE"]
183 methods ∷ Maybe a → [Ascii] → [Ascii]
188 toAbortion ∷ SomeException → Abortion
190 = case fromException e of
191 Just abortion → abortion
192 Nothing → mkAbortion' InternalServerError $ T.pack $ show e
194 processException ∷ SomeException → IO ()
196 = do let abo = toAbortion exc
197 state ← atomically $ readTVar niState
198 res ← atomically $ readTVar niResponse
199 if state ≤ DecidingHeader then
200 -- We still have a chance to reflect this abortion
201 -- in the response. Hooray!
203 do setStatus $ aboStatus abo
204 mapM_ (uncurry setHeader) (aboHeaders abo)
205 setHeader "Content-Type" defaultPageContentType
206 deleteHeader "Content-Encoding"
207 putBuilder $ abortPage niConfig (Just niRequest) res abo
209 when (cnfDumpTooLateAbortionToStderr niConfig)
211 runRsrc (driftTo Done) ni
213 dumpAbortion ∷ Abortion → IO ()
216 $ concat [ "Lucu: an exception occured after "
217 , "sending the response header to the client:\n"
218 , " ", show abo, "\n"
221 getInteraction ∷ Rsrc NormalInteraction
222 getInteraction = Rsrc ask
224 -- |Get the 'Config' value for this httpd.
225 getConfig ∷ Rsrc Config
226 getConfig = niConfig <$> getInteraction
228 -- |Get the 'SockAddr' of the remote host.
229 getRemoteAddr ∷ Rsrc SockAddr
230 getRemoteAddr = niRemoteAddr <$> getInteraction
232 #if defined(HAVE_SSL)
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 ∷ Rsrc (Maybe X509)
243 getRemoteCertificate = niRemoteCert <$> getInteraction
246 -- |Return the 'Request' value representing the request header. You
247 -- usually don't need to call this function directly.
248 getRequest ∷ Rsrc Request
249 getRequest = niRequest <$> getInteraction
251 -- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
252 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
253 -- action is the exact path in the tree even when the 'Resource' is
258 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
259 -- > in runHttpd defaultConfig tree []
261 -- > resFoo = emptyResource {
262 -- > resIsGreedy = True
263 -- > , resGet = Just $ do requestURI <- getRequestURI
264 -- > resourcePath <- getResourcePath
265 -- > pathInfo <- getPathInfo
266 -- > -- uriPath requestURI == "/foo/bar/baz"
267 -- > -- resourcePath == ["foo"]
268 -- > -- pathInfo == ["bar", "baz"]
271 getResourcePath ∷ Rsrc PathSegments
272 getResourcePath = niResourcePath <$> getInteraction
274 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
275 -- bytes. You can incrementally read the request body by repeatedly
276 -- calling this function. If there is nothing to be read anymore,
277 -- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
278 -- /Deciding Header/ state.
279 getChunk ∷ Int → Rsrc ByteString
280 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
282 getChunk' ∷ Int → Rsrc ByteString
284 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
286 | otherwise = do req ← getRequest
287 if reqMustHaveBody req then
288 askForInput =≪ getInteraction
290 driftTo DecidingHeader *> return (∅)
292 askForInput ∷ NormalInteraction → Rsrc ByteString
293 askForInput (NI {..})
294 = do -- Ask the RequestReader to get a chunk.
296 $ putTMVar niReceiveBodyReq (ReceiveBody n)
297 -- Then wait for a reply.
300 $ takeTMVar niReceivedBody
301 -- Have we got an EOF?
303 $ driftTo DecidingHeader
306 -- |Declare the response status code. If you don't call this function,
307 -- the status code will be defaulted to \"200 OK\".
308 setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
310 = do ni ← getInteraction
312 $ do state ← readTVar $ niState ni
313 when (state > DecidingHeader)
314 $ fail "Too late to declare the response status."
315 res ← readTVar $ niResponse ni
316 writeTVar (niResponse ni) $ setStatusCode sc res
318 -- |@'setHeader' name value@ declares the value of the response header
319 -- @name@ as @value@. Note that this function is not intended to be
320 -- used so frequently: there should be specialised functions like
321 -- 'setContentType' for every common headers.
323 -- Some important headers (especially \"Content-Length\" and
324 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
325 -- the system not to corrupt the interaction with client at the
326 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
327 -- the connection alive, without this manipulation it will be a
328 -- catastrophe when we send a header \"Content-Length: 10\" and
329 -- actually send a body of 20 bytes long to the remote peer. In this
330 -- case the client shall only accept the first 10 bytes of response
331 -- body and thinks that the residual 10 bytes is a part of the header
332 -- of the next response.
333 setHeader ∷ CIAscii → Ascii → Rsrc ()
334 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
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 → Rsrc ()
349 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
351 go ∷ NormalInteraction → STM ()
353 = do state ← readTVar niState
354 when (state > DecidingHeader) $
355 fail "Too late to delete a response header field."
356 res ← readTVar niResponse
357 writeTVar niResponse $ H.deleteHeader name res
358 when (name ≡ "Content-Type") $
359 writeTVar niResponseHasCType False
361 -- |Run a 'Builder' to construct a chunk, and write it to the response
362 -- body. It can be safely applied to a 'Builder' producing an
363 -- infinitely long stream of octets.
365 -- Note that you must first declare the response header
366 -- \"Content-Type\" before applying this function. See:
368 putBuilder ∷ Builder → Rsrc ()
369 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
371 -- FIXME: should see if resCanHaveBody.
372 go ∷ NormalInteraction → STM ()
374 = do driftTo' ni SendingBody
375 hasCType ← readTVar niResponseHasCType
378 $ mkAbortion' InternalServerError
379 "putBuilder: Content-Type has not been set."
380 putTMVar niBodyToSend b
382 driftTo ∷ InteractionState → Rsrc ()
383 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
385 driftTo' ∷ NormalInteraction → InteractionState → STM ()
386 driftTo' ni@(NI {..}) newState
387 = do oldState ← readTVar niState
390 driftFrom ∷ InteractionState → STM ()
392 | newState < oldState = throwStateError oldState newState
393 | newState ≡ oldState = return ()
395 = do let a = [oldState .. newState]
398 mapM_ (uncurry driftFromTo) c
399 writeTVar niState newState
401 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
402 throwStateError Done SendingBody
403 = fail "It makes no sense to output something after finishing outputs."
404 throwStateError old new
405 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
407 driftFromTo ∷ InteractionState → InteractionState → STM ()
408 driftFromTo ReceivingBody _
409 = putTMVar niReceiveBodyReq WasteAll
410 driftFromTo DecidingHeader _