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 Data.Ascii (Ascii, CIAscii)
39 import qualified Data.Ascii as A
40 import qualified Data.ByteString as Strict
43 import Data.Monoid.Unicode
44 import Data.Text (Text)
45 import qualified Data.Text as T
46 import Network.HTTP.Lucu.Abortion
47 import Network.HTTP.Lucu.Config
48 import Network.HTTP.Lucu.DefaultPage
49 import qualified Network.HTTP.Lucu.Headers as H
50 import Network.HTTP.Lucu.Interaction
51 import Network.HTTP.Lucu.Postprocess
52 import Network.HTTP.Lucu.Request
53 import Network.HTTP.Lucu.Response
54 import Network.HTTP.Lucu.Utils
57 import Prelude hiding (catch)
58 import Prelude.Unicode
61 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
65 unResource ∷ ReaderT Interaction IO a
67 deriving (Applicative, Functor, Monad, MonadIO)
69 runResource ∷ Resource a → Interaction → IO a
70 runResource = runReaderT ∘ unResource
72 -- |'ResourceDef' is basically a set of 'Resource' monads for each
74 data ResourceDef = ResourceDef {
75 -- |Whether to run a 'Resource' on a native thread (spawned by
76 -- 'forkOS') or to run it on a user thread (spanwed by
77 -- 'forkIO'). Generally you don't need to set this field to
79 resUsesNativeThread ∷ !Bool
80 -- | Whether to be greedy or not.
82 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
83 -- greedy resource at \/aaa\/bbb, it is always chosen even if
84 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
85 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
86 -- resources are like CGI scripts.
88 -- |A 'Resource' to be run when a GET request comes for the
89 -- resource path. If 'resGet' is Nothing, the system responds
90 -- \"405 Method Not Allowed\" for GET requests.
92 -- It also runs for HEAD request if the 'resHead' is Nothing. In
93 -- this case 'output' and such like don't actually write a
95 , resGet ∷ !(Maybe (Resource ()))
96 -- |A 'Resource' to be run when a HEAD request comes for the
97 -- resource path. If 'resHead' is Nothing, the system runs
98 -- 'resGet' instead. If 'resGet' is also Nothing, the system
99 -- responds \"405 Method Not Allowed\" for HEAD requests.
100 , resHead ∷ !(Maybe (Resource ()))
101 -- |A 'Resource' to be run when a POST request comes for the
102 -- resource path. If 'resPost' is Nothing, the system responds
103 -- \"405 Method Not Allowed\" for POST requests.
104 , resPost ∷ !(Maybe (Resource ()))
105 -- |A 'Resource' to be run when a PUT request comes for the
106 -- resource path. If 'resPut' is Nothing, the system responds
107 -- \"405 Method Not Allowed\" for PUT requests.
108 , resPut ∷ !(Maybe (Resource ()))
109 -- |A 'Resource' to be run when a DELETE request comes for the
110 -- resource path. If 'resDelete' is Nothing, the system responds
111 -- \"405 Method Not Allowed\" for DELETE requests.
112 , resDelete ∷ !(Maybe (Resource ()))
115 -- |'emptyResource' is a resource definition with no actual
116 -- handlers. You can construct a 'ResourceDef' by selectively
117 -- overriding 'emptyResource'. It is defined as follows:
120 -- emptyResource = ResourceDef {
121 -- resUsesNativeThread = False
122 -- , resIsGreedy = False
123 -- , resGet = Nothing
124 -- , resHead = Nothing
125 -- , resPost = Nothing
126 -- , resPut = Nothing
127 -- , resDelete = Nothing
130 emptyResource ∷ ResourceDef
131 emptyResource = ResourceDef {
132 resUsesNativeThread = False
133 , resIsGreedy = False
138 , resDelete = Nothing
141 spawnResource ∷ ResourceDef → Interaction → IO ThreadId
142 spawnResource (ResourceDef {..}) itr@(Interaction {..})
143 = fork $ run `catch` processException
145 fork ∷ IO () → IO ThreadId
146 fork | resUsesNativeThread = forkOS
150 run = flip runResource itr $
152 fromMaybe notAllowed $ rsrc req
155 rsrc ∷ Request → Maybe (Resource ())
157 = case reqMethod req of
159 HEAD → case resHead of
165 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
167 notAllowed ∷ Resource ()
169 = setStatus MethodNotAllowed
171 (setHeader "Allow" $ A.fromAsciiBuilder
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 → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
194 processException ∷ SomeException → IO ()
196 = do let abo = toAbortion exc
197 state ← atomically $ readTVar itrState
198 res ← atomically $ readTVar itrResponse
199 if state ≤ DecidingHeader then
200 -- We still have a chance to reflect this abortion
201 -- in the response. Hooray!
202 flip runResource itr $
203 do setStatus $ aboStatus abo
204 setHeader "Content-Type" defaultPageContentType
205 deleteHeader "Content-Encoding"
206 mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
207 putBuilder $ abortPage itrConfig itrRequest res abo
209 when (cnfDumpTooLateAbortionToStderr itrConfig)
211 runResource (driftTo Done) itr
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 ∷ Resource Interaction
222 getInteraction = Resource ask
224 -- |Get the 'Config' value for this httpd.
225 getConfig ∷ Resource Config
226 getConfig = itrConfig <$> getInteraction
228 -- |Get the 'SockAddr' of the remote host.
229 getRemoteAddr ∷ Resource SockAddr
230 getRemoteAddr = itrRemoteAddr <$> getInteraction
232 -- | Return the X.509 certificate of the client, or 'Nothing' if:
234 -- * This request didn't came through an SSL stream.
236 -- * The client didn't send us its certificate.
238 -- * The 'OpenSSL.Session.VerificationMode' of
239 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
240 -- 'OpenSSL.Session.VerifyPeer'.
241 getRemoteCertificate ∷ Resource (Maybe X509)
242 getRemoteCertificate = itrRemoteCert <$> getInteraction
244 -- |Return the 'Request' value representing the request header. You
245 -- usually don't need to call this function directly.
246 getRequest ∷ Resource Request
247 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
249 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
250 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
251 -- action is the exact path in the tree even when the 'ResourceDef' is
256 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
257 -- > in runHttpd defaultConfig tree []
259 -- > resFoo = ResourceDef {
260 -- > resIsGreedy = True
261 -- > , resGet = Just $ do requestURI <- getRequestURI
262 -- > resourcePath <- getResourcePath
263 -- > pathInfo <- getPathInfo
264 -- > -- uriPath requestURI == "/foo/bar/baz"
265 -- > -- resourcePath == ["foo"]
266 -- > -- pathInfo == ["bar", "baz"]
270 getResourcePath ∷ Resource [Text]
271 getResourcePath = (fromJust ∘ itrResourcePath) <$> 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 do itr ← getInteraction
290 driftTo DecidingHeader *> return (∅)
292 askForInput ∷ Interaction → Resource Strict.ByteString
293 askForInput (Interaction {..})
294 = do -- Ask the RequestReader to get a chunk.
296 $ putTMVar itrReceiveBodyReq (ReceiveBody n)
297 -- Then wait for a reply.
300 $ takeTMVar itrReceivedBody
301 -- Have we got an EOF?
302 when (Strict.null chunk)
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 → Resource ()
310 = do itr ← getInteraction
312 $ do state ← readTVar $ itrState itr
313 when (state > DecidingHeader)
314 $ fail "Too late to declare the response status."
315 setResponseStatus itr sc
317 -- |@'setHeader' name value@ declares the value of the response header
318 -- @name@ as @value@. Note that this function is not intended to be
319 -- used so frequently: there should be specialised functions like
320 -- 'setContentType' for every common headers.
322 -- Some important headers (especially \"Content-Length\" and
323 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
324 -- the system not to corrupt the interaction with client at the
325 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
326 -- the connection alive, without this manipulation it will be a
327 -- catastrophe when we send a header \"Content-Length: 10\" and
328 -- actually send a body of 20 bytes long to the remote peer. In this
329 -- case the client shall only accept the first 10 bytes of response
330 -- body and thinks that the residual 10 bytes is a part of the header
331 -- of the next response.
332 setHeader ∷ CIAscii → Ascii → Resource ()
334 = do itr ← getInteraction
336 $ do state ← readTVar $ itrState itr
337 when (state > DecidingHeader)
338 $ fail "Too late to declare a response header field."
339 res ← readTVar $ itrResponse itr
340 let res' = H.setHeader name value res
341 writeTVar (itrResponse itr) res'
342 when (name ≡ "Content-Type")
343 $ writeTVar (itrResponseHasCType itr) True
345 -- |@'deleteHeader' name@ deletes a response header @name@ if
346 -- any. This function is not intended to be used so frequently.
347 deleteHeader ∷ CIAscii → Resource ()
349 = do itr ← getInteraction
351 $ do state ← readTVar $ itrState itr
352 when (state > DecidingHeader)
353 $ fail "Too late to delete a response header field."
354 res ← readTVar $ itrResponse itr
355 let res' = H.deleteHeader name res
356 writeTVar (itrResponse itr) res'
357 when (name ≡ "Content-Type")
358 $ writeTVar (itrResponseHasCType itr) False
360 -- |Run a 'Builder' to construct a chunk, and write it to the response
361 -- body. It is safe to apply this function to a 'Builder' producing an
362 -- infinitely long stream of octets.
364 -- Note that you must first declare the response header
365 -- \"Content-Type\" before applying this function. See
367 putBuilder ∷ Builder → Resource ()
369 = do itr ← getInteraction
371 $ do driftTo' itr SendingBody
372 hasCType ← readTVar $ itrResponseHasCType itr
374 $ abortSTM InternalServerError []
375 $ Just "putBuilder: Content-Type has not been set."
376 putTMVar (itrBodyToSend itr) b
378 driftTo ∷ InteractionState → Resource ()
380 = do itr ← getInteraction
381 liftIO $ atomically $ driftTo' itr newState
383 driftTo' ∷ Interaction → InteractionState → STM ()
384 driftTo' itr@(Interaction {..}) newState
385 = do oldState ← readTVar itrState
388 driftFrom ∷ InteractionState → STM ()
390 | newState < oldState = throwStateError oldState newState
391 | newState ≡ oldState = return ()
393 = do let a = [oldState .. newState]
396 mapM_ (uncurry driftFromTo) c
397 writeTVar itrState newState
399 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
400 throwStateError Done SendingBody
401 = fail "It makes no sense to output something after finishing outputs."
402 throwStateError old new
403 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
405 driftFromTo ∷ InteractionState → InteractionState → STM ()
406 driftFromTo ReceivingBody _
407 = putTMVar itrReceiveBodyReq WasteAll
408 driftFromTo DecidingHeader _