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 qualified Data.Text as T
45 import Network.HTTP.Lucu.Abortion
46 import Network.HTTP.Lucu.Config
47 import Network.HTTP.Lucu.DefaultPage
48 import qualified Network.HTTP.Lucu.Headers as H
49 import Network.HTTP.Lucu.Interaction
50 import Network.HTTP.Lucu.Postprocess
51 import Network.HTTP.Lucu.Request
52 import Network.HTTP.Lucu.Response
53 import Network.HTTP.Lucu.Utils
56 import Prelude hiding (catch)
57 import Prelude.Unicode
60 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
64 unResource ∷ ReaderT Interaction IO a
66 deriving (Applicative, Functor, Monad, MonadIO)
68 runResource ∷ Resource a → Interaction → IO a
69 runResource = runReaderT ∘ unResource
71 -- |'ResourceDef' is basically a set of 'Resource' monads for each
73 data ResourceDef = ResourceDef {
74 -- |Whether to run a 'Resource' on a native thread (spawned by
75 -- 'forkOS') or to run it on a user thread (spanwed by
76 -- 'forkIO'). Generally you don't need to set this field to
78 resUsesNativeThread ∷ !Bool
79 -- | Whether to be greedy or not.
81 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
82 -- greedy resource at \/aaa\/bbb, it is always chosen even if
83 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
84 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
85 -- resources are like CGI scripts.
87 -- |A 'Resource' to be run when a GET request comes for the
88 -- resource path. If 'resGet' is Nothing, the system responds
89 -- \"405 Method Not Allowed\" for GET requests.
91 -- It also runs for HEAD request if the 'resHead' is Nothing. In
92 -- this case 'output' and such like don't actually write a
94 , resGet ∷ !(Maybe (Resource ()))
95 -- |A 'Resource' to be run when a HEAD request comes for the
96 -- resource path. If 'resHead' is Nothing, the system runs
97 -- 'resGet' instead. If 'resGet' is also Nothing, the system
98 -- responds \"405 Method Not Allowed\" for HEAD requests.
99 , resHead ∷ !(Maybe (Resource ()))
100 -- |A 'Resource' to be run when a POST request comes for the
101 -- resource path. If 'resPost' is Nothing, the system responds
102 -- \"405 Method Not Allowed\" for POST requests.
103 , resPost ∷ !(Maybe (Resource ()))
104 -- |A 'Resource' to be run when a PUT request comes for the
105 -- resource path. If 'resPut' is Nothing, the system responds
106 -- \"405 Method Not Allowed\" for PUT requests.
107 , resPut ∷ !(Maybe (Resource ()))
108 -- |A 'Resource' to be run when a DELETE request comes for the
109 -- resource path. If 'resDelete' is Nothing, the system responds
110 -- \"405 Method Not Allowed\" for DELETE requests.
111 , resDelete ∷ !(Maybe (Resource ()))
114 -- |'emptyResource' is a resource definition with no actual
115 -- handlers. You can construct a 'ResourceDef' by selectively
116 -- overriding 'emptyResource'. It is defined as follows:
119 -- emptyResource = ResourceDef {
120 -- resUsesNativeThread = False
121 -- , resIsGreedy = False
122 -- , resGet = Nothing
123 -- , resHead = Nothing
124 -- , resPost = Nothing
125 -- , resPut = Nothing
126 -- , resDelete = Nothing
129 emptyResource ∷ ResourceDef
130 emptyResource = ResourceDef {
131 resUsesNativeThread = False
132 , resIsGreedy = False
137 , resDelete = Nothing
140 spawnResource ∷ ResourceDef → Interaction → IO ThreadId
141 spawnResource (ResourceDef {..}) itr@(Interaction {..})
142 = fork $ run `catch` processException
144 fork ∷ IO () → IO ThreadId
145 fork | resUsesNativeThread = forkOS
149 run = flip runResource itr $
151 fromMaybe notAllowed $ rsrc req
154 rsrc ∷ Request → Maybe (Resource ())
156 = case reqMethod req of
158 HEAD → case resHead of
164 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
166 notAllowed ∷ Resource ()
168 = setStatus MethodNotAllowed
170 (setHeader "Allow" $ A.fromAsciiBuilder
172 $ map A.toAsciiBuilder allowedMethods)
174 allowedMethods ∷ [Ascii]
175 allowedMethods = nub $ concat [ methods resGet ["GET"]
176 , methods resHead ["GET", "HEAD"]
177 , methods resPost ["POST"]
178 , methods resPut ["PUT"]
179 , methods resDelete ["DELETE"]
182 methods ∷ Maybe a → [Ascii] → [Ascii]
187 toAbortion ∷ SomeException → Abortion
189 = case fromException e of
190 Just abortion → abortion
191 Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
193 processException ∷ SomeException → IO ()
195 = do let abo = toAbortion exc
196 state ← atomically $ readTVar itrState
197 res ← atomically $ readTVar itrResponse
198 if state ≤ DecidingHeader then
199 -- We still have a chance to reflect this abortion
200 -- in the response. Hooray!
201 flip runResource itr $
202 do setStatus $ aboStatus abo
203 setHeader "Content-Type" defaultPageContentType
204 deleteHeader "Content-Encoding"
205 mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
206 putBuilder $ abortPage itrConfig itrRequest res abo
208 when (cnfDumpTooLateAbortionToStderr itrConfig)
210 runResource (driftTo Done) itr
212 dumpAbortion ∷ Abortion → IO ()
215 $ concat [ "Lucu: an exception occured after "
216 , "sending the response header to the client:\n"
217 , " ", show abo, "\n"
220 getInteraction ∷ Resource Interaction
221 getInteraction = Resource ask
223 -- |Get the 'Config' value for this httpd.
224 getConfig ∷ Resource Config
225 getConfig = itrConfig <$> getInteraction
227 -- |Get the 'SockAddr' of the remote host.
228 getRemoteAddr ∷ Resource SockAddr
229 getRemoteAddr = itrRemoteAddr <$> getInteraction
231 -- | Return the X.509 certificate of the client, or 'Nothing' if:
233 -- * This request didn't came through an SSL stream.
235 -- * The client didn't send us its certificate.
237 -- * The 'OpenSSL.Session.VerificationMode' of
238 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
239 -- 'OpenSSL.Session.VerifyPeer'.
240 getRemoteCertificate ∷ Resource (Maybe X509)
241 getRemoteCertificate = itrRemoteCert <$> getInteraction
243 -- |Return the 'Request' value representing the request header. You
244 -- usually don't need to call this function directly.
245 getRequest ∷ Resource Request
246 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
248 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
249 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
250 -- action is the exact path in the tree even when the 'ResourceDef' is
255 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
256 -- > in runHttpd defaultConfig tree []
258 -- > resFoo = ResourceDef {
259 -- > resIsGreedy = True
260 -- > , resGet = Just $ do requestURI <- getRequestURI
261 -- > resourcePath <- getResourcePath
262 -- > pathInfo <- getPathInfo
263 -- > -- uriPath requestURI == "/foo/bar/baz"
264 -- > -- resourcePath == ["foo"]
265 -- > -- pathInfo == ["bar", "baz"]
269 getResourcePath ∷ Resource [Strict.ByteString]
270 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
272 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
273 -- bytes. You can incrementally read the request body by repeatedly
274 -- calling this function. If there is nothing to be read anymore,
275 -- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
276 -- the /Deciding Header/ state.
277 getChunk ∷ Int → Resource Strict.ByteString
278 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
280 getChunk' ∷ Int → Resource Strict.ByteString
282 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
284 | otherwise = do req ← getRequest
285 if reqMustHaveBody req then
286 do itr ← getInteraction
289 driftTo DecidingHeader *> return (∅)
291 askForInput ∷ Interaction → Resource Strict.ByteString
292 askForInput (Interaction {..})
293 = do -- Ask the RequestReader to get a chunk.
295 $ putTMVar itrReceiveBodyReq (ReceiveBody n)
296 -- Then wait for a reply.
299 $ takeTMVar itrReceivedBody
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 itr ← getInteraction
311 $ do state ← readTVar $ itrState itr
312 when (state > DecidingHeader)
313 $ fail "Too late to declare the response status."
314 setResponseStatus itr 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 itr ← getInteraction
335 $ do state ← readTVar $ itrState itr
336 when (state > DecidingHeader)
337 $ fail "Too late to declare a response header field."
338 res ← readTVar $ itrResponse itr
339 let res' = H.setHeader name value res
340 writeTVar (itrResponse itr) res'
341 when (name ≡ "Content-Type")
342 $ writeTVar (itrResponseHasCType itr) 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 ()
348 = do itr ← getInteraction
350 $ do state ← readTVar $ itrState itr
351 when (state > DecidingHeader)
352 $ fail "Too late to delete a response header field."
353 res ← readTVar $ itrResponse itr
354 let res' = H.deleteHeader name res
355 writeTVar (itrResponse itr) res'
356 when (name ≡ "Content-Type")
357 $ writeTVar (itrResponseHasCType itr) False
359 -- |Run a 'Builder' to construct a chunk, and write it to the response
360 -- body. It is safe to apply this function 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 ()
368 = do itr ← getInteraction
370 $ do driftTo' itr SendingBody
371 hasCType ← readTVar $ itrResponseHasCType itr
373 $ abortSTM InternalServerError []
374 $ Just "putBuilder: Content-Type has not been set."
375 putTMVar (itrBodyToSend itr) b
377 driftTo ∷ InteractionState → Resource ()
379 = do itr ← getInteraction
380 liftIO $ atomically $ driftTo' itr newState
382 driftTo' ∷ Interaction → InteractionState → STM ()
383 driftTo' itr@(Interaction {..}) newState
384 = do oldState ← readTVar itrState
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 itrState 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 itrReceiveBodyReq WasteAll
407 driftFromTo DecidingHeader _