5 , GeneralizedNewtypeDeriving
7 , MultiParamTypeClasses
11 module Network.HTTP.Lucu.Resource.Internal
19 , getRemoteCertificate
35 import Blaze.ByteString.Builder (Builder)
36 import Control.Applicative
37 import Control.Concurrent
38 import Control.Concurrent.STM
39 import Control.Exception
40 import Control.Monad hiding (mapM_)
41 import Control.Monad.Fix
42 import Control.Monad.IO.Class
43 import Control.Monad.Reader (ReaderT, runReaderT, ask)
44 import Control.Monad.Unicode
45 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
46 import Data.ByteString (ByteString)
47 import qualified Data.ByteString as BS
48 import Data.Collections
49 import Data.Convertible.Base
50 import Data.Convertible.Instances.Text ()
51 import Data.List (intersperse, nub)
54 import Data.Monoid.Unicode
55 import Network.HTTP.Lucu.Abortion
56 import Network.HTTP.Lucu.Abortion.Internal
57 import Network.HTTP.Lucu.Config
58 import Network.HTTP.Lucu.DefaultPage
59 import qualified Network.HTTP.Lucu.Headers as H
60 import Network.HTTP.Lucu.Interaction
61 import Network.HTTP.Lucu.Postprocess
62 import Network.HTTP.Lucu.Request
63 import Network.HTTP.Lucu.Response
64 import Network.HTTP.Lucu.Response.StatusCode
65 import Network.HTTP.Lucu.Utils
70 import Prelude hiding (catch, concat, filter, mapM_, tail)
71 import Prelude.Unicode
74 -- |The resource monad. This monad implements 'MonadIO' so it can do
78 unRsrc ∷ ReaderT NormalInteraction IO a
80 deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
82 runRsrc ∷ Rsrc a → NormalInteraction → IO a
83 runRsrc = runReaderT ∘ unRsrc
85 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
87 data Resource = Resource {
88 -- |A 'Rsrc' 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 -- that case 'putChunk' and such don't actually write a response
95 resGet ∷ !(Maybe (Rsrc ()))
96 -- |A 'Rsrc' 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 (Rsrc ()))
101 -- |A 'Rsrc' 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 (Rsrc ()))
105 -- |A 'Rsrc' 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 (Rsrc ()))
109 -- |A 'Rsrc' 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 (Rsrc ()))
115 instance Monoid Resource where
116 {-# INLINE mempty #-}
123 , resDelete = Nothing
125 {-# INLINEABLE mappend #-}
128 resGet = resGet a <|> resGet b
129 , resHead = resHead a <|> resHead b
130 , resPost = resPost a <|> resPost b
131 , resPut = resPut a <|> resPut b
132 , resDelete = resDelete a <|> resDelete b
135 instance Unfoldable Resource (Method, Rsrc ()) where
136 {-# INLINEABLE insert #-}
137 insert (GET , a) r = r { resGet = Just a }
138 insert (HEAD , a) r = r { resHead = Just a }
139 insert (POST , a) r = r { resPost = Just a }
140 insert (PUT , a) r = r { resPut = Just a }
141 insert (DELETE, a) r = r { resDelete = Just a }
146 instance Foldable Resource (Method, Rsrc ()) where
147 {-# INLINEABLE foldMap #-}
148 foldMap f (Resource {..})
149 = maybe (∅) (f ∘ ((,) GET )) resGet ⊕
150 maybe (∅) (f ∘ ((,) HEAD )) resHead ⊕
151 maybe (∅) (f ∘ ((,) POST )) resPost ⊕
152 maybe (∅) (f ∘ ((,) PUT )) resPut ⊕
153 maybe (∅) (f ∘ ((,) DELETE)) resDelete
155 instance Collection Resource (Method, Rsrc ()) where
156 {-# INLINE filter #-}
157 filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
159 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
160 spawnRsrc (Resource {..}) ni@(NI {..})
161 = forkIO $ run `catch` processException
164 run = flip runRsrc ni $
166 fromMaybe notAllowed $ rsrc req
169 rsrc ∷ Request → Maybe (Rsrc ())
171 = case reqMethod req of
173 HEAD → case resHead of
179 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
182 notAllowed = do setStatus MethodNotAllowed
186 $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
187 $ map cs allowedMethods
189 allowedMethods ∷ [Ascii]
190 allowedMethods = nub $ concat [ methods resGet ["GET", "HEAD"]
191 , methods resHead ["HEAD"]
192 , methods resPost ["POST"]
193 , methods resPut ["PUT"]
194 , methods resDelete ["DELETE"]
197 methods ∷ Maybe a → [Ascii] → [Ascii]
202 toAbortion ∷ SomeException → Abortion
204 = case fromException e of
205 Just abortion → abortion
206 Nothing → mkAbortion' InternalServerError $ cs $ show e
208 processException ∷ SomeException → IO ()
210 = do let abo = toAbortion exc
211 state ← atomically $ readTVar niState
212 res ← atomically $ readTVar niResponse
213 if state ≤ DecidingHeader then
214 -- We still have a chance to reflect this abortion
215 -- in the response. Hooray!
217 do setStatus $ aboStatus abo
218 mapM_ (uncurry setHeader) (aboHeaders abo)
219 setHeader "Content-Type" defaultPageContentType
220 deleteHeader "Content-Encoding"
221 putBuilder $ abortPage niConfig (Just niRequest) res abo
223 when (cnfDumpTooLateAbortionToStderr niConfig)
225 runRsrc (driftTo Done) ni
227 dumpAbortion ∷ Abortion → IO ()
230 $ concat [ "Lucu: an exception occured after "
231 , "sending the response header to the client:\n"
232 , " ", show abo, "\n"
235 getInteraction ∷ Rsrc NormalInteraction
236 getInteraction = Rsrc ask
238 -- |Get the 'Config' value for this httpd.
239 getConfig ∷ Rsrc Config
240 getConfig = niConfig <$> getInteraction
242 -- |Get the 'SockAddr' of the remote host.
243 getRemoteAddr ∷ Rsrc SockAddr
244 getRemoteAddr = niRemoteAddr <$> getInteraction
246 #if defined(HAVE_SSL)
247 -- | Return the X.509 certificate of the client, or 'Nothing' if:
249 -- * This request didn't came through an SSL stream.
251 -- * The client didn't send us its certificate.
253 -- * The 'OpenSSL.Session.VerificationMode' of
254 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
255 -- 'OpenSSL.Session.VerifyPeer'.
256 getRemoteCertificate ∷ Rsrc (Maybe X509)
257 getRemoteCertificate = niRemoteCert <$> getInteraction
260 -- |Return the 'Request' value representing the request header. You
261 -- usually don't need to call this function directly.
262 getRequest ∷ Rsrc Request
263 getRequest = niRequest <$> getInteraction
265 -- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
266 -- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
267 -- action is the exact path in the tree even when the 'Resource' is
268 -- 'Network.HTTP.Lucu.greedy'.
274 -- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
275 -- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
276 -- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
278 -- resFoo :: 'Resource'
279 -- resFoo = 'singleton'
281 -- , do requestURI <- 'getRequestURI'
282 -- resourcePath <- 'getResourcePath'
283 -- pathInfo <- 'getPathInfo'
284 -- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
285 -- -- resourcePath == ["foo"]
286 -- -- pathInfo == ["bar", "baz"]
290 getResourcePath ∷ Rsrc Path
291 getResourcePath = niResourcePath <$> getInteraction
293 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
294 -- bytes. You can incrementally read the request body by repeatedly
295 -- calling this function. If there is nothing to be read anymore,
296 -- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
297 -- /Deciding Header/ state.
298 getChunk ∷ Int → Rsrc ByteString
299 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
301 getChunk' ∷ Int → Rsrc ByteString
303 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
305 | otherwise = do req ← getRequest
306 if reqHasBody req then
307 askForInput =≪ getInteraction
309 driftTo DecidingHeader *> return (∅)
311 askForInput ∷ NormalInteraction → Rsrc ByteString
312 askForInput (NI {..})
313 = do -- Ask the RequestReader to get a chunk.
315 $ putTMVar niReceiveBodyReq (ReceiveBody n)
316 -- Then wait for a reply.
319 $ takeTMVar niReceivedBody
320 -- Have we got an EOF?
322 $ driftTo DecidingHeader
325 -- |Declare the response status code. If you don't call this function,
326 -- the status code will be defaulted to \"200 OK\".
327 setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
329 = do ni ← getInteraction
331 $ do state ← readTVar $ niState ni
332 when (state > DecidingHeader)
333 $ fail "Too late to declare the response status."
334 res ← readTVar $ niResponse ni
335 writeTVar (niResponse ni) $ setStatusCode sc res
337 -- |@'setHeader' name value@ declares the value of the response header
338 -- @name@ as @value@. Note that this function is not intended to be
339 -- used so frequently: there should be specialised functions like
340 -- 'Network.HTTP.Lucu.setContentType' for every common headers.
342 -- Some important headers (especially \"Content-Length\" and
343 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
344 -- the system not to corrupt the interaction with client at the
345 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
346 -- the connection alive, without this manipulation it will be a
347 -- catastrophe when we send a header \"Content-Length: 10\" and
348 -- actually send a body of 20 bytes long to the remote peer. In this
349 -- case the client shall only accept the first 10 bytes of response
350 -- body and thinks that the residual 10 bytes is a part of the header
351 -- of the next response.
352 setHeader ∷ CIAscii → Ascii → Rsrc ()
353 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
355 go ∷ NormalInteraction → STM ()
357 = do state ← readTVar niState
358 when (state > DecidingHeader) $
359 fail "Too late to declare a response header field."
360 res ← readTVar niResponse
361 writeTVar niResponse $ H.setHeader name value res
362 when (name ≡ "Content-Type") $
363 writeTVar niResponseHasCType True
365 -- |@'deleteHeader' name@ deletes a response header @name@ if
366 -- any. This function is not intended to be used so frequently.
367 deleteHeader ∷ CIAscii → Rsrc ()
368 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
370 go ∷ NormalInteraction → STM ()
372 = do state ← readTVar niState
373 when (state > DecidingHeader) $
374 fail "Too late to delete a response header field."
375 res ← readTVar niResponse
376 writeTVar niResponse $ H.deleteHeader name res
377 when (name ≡ "Content-Type") $
378 writeTVar niResponseHasCType False
380 -- |Run a 'Builder' to construct a chunk, and write it to the response
381 -- body. It can be safely applied to a 'Builder' producing an
382 -- infinitely long stream of octets.
384 -- Note that you must first declare the response header
385 -- \"Content-Type\" before applying this function. See
386 -- 'Network.HTTP.Lucu.setContentType'.
387 putBuilder ∷ Builder → Rsrc ()
388 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
390 -- FIXME: should see if resCanHaveBody.
391 go ∷ NormalInteraction → STM ()
393 = do driftTo' ni SendingBody
394 hasCType ← readTVar niResponseHasCType
397 $ mkAbortion' InternalServerError
398 "putBuilder: Content-Type has not been set."
399 putTMVar niBodyToSend b
401 driftTo ∷ InteractionState → Rsrc ()
402 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
404 driftTo' ∷ NormalInteraction → InteractionState → STM ()
405 driftTo' ni@(NI {..}) newState
406 = do oldState ← readTVar niState
409 driftFrom ∷ InteractionState → STM ()
411 | newState < oldState = throwStateError oldState newState
412 | newState ≡ oldState = return ()
414 = do let a = [oldState .. newState]
417 mapM_ (uncurry driftFromTo) c
418 writeTVar niState newState
420 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
421 throwStateError Done SendingBody
422 = fail "It makes no sense to output something after finishing outputs."
423 throwStateError old new
424 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
426 driftFromTo ∷ InteractionState → InteractionState → STM ()
427 driftFromTo ReceivingBody _
428 = putTMVar niReceiveBodyReq WasteAll
429 driftFromTo DecidingHeader _