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)
46 import qualified Data.Ascii as A
47 import Data.ByteString (ByteString)
48 import qualified Data.ByteString as BS
49 import Data.Collections
50 import Data.List (intersperse, nub)
53 import Data.Monoid.Unicode
54 import qualified Data.Text as T
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.Utils
69 import Prelude hiding (catch, concat, filter, mapM_, tail)
70 import Prelude.Unicode
73 -- |The resource monad. This monad implements 'MonadIO' so it can do
77 unRsrc ∷ ReaderT NormalInteraction IO a
79 deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
81 runRsrc ∷ Rsrc a → NormalInteraction → IO a
82 runRsrc = runReaderT ∘ unRsrc
84 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
86 data Resource = Resource {
87 -- |A 'Rsrc' 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 -- that case 'putChunk' and such don't actually write a response
94 resGet ∷ !(Maybe (Rsrc ()))
95 -- |A 'Rsrc' 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 (Rsrc ()))
100 -- |A 'Rsrc' 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 (Rsrc ()))
104 -- |A 'Rsrc' 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 (Rsrc ()))
108 -- |A 'Rsrc' 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 (Rsrc ()))
114 instance Monoid Resource where
115 {-# INLINE mempty #-}
122 , resDelete = Nothing
124 {-# INLINEABLE mappend #-}
127 resGet = resGet a <|> resGet b
128 , resHead = resHead a <|> resHead b
129 , resPost = resPost a <|> resPost b
130 , resPut = resPut a <|> resPut b
131 , resDelete = resDelete a <|> resDelete b
134 instance Unfoldable Resource (Method, Rsrc ()) where
135 {-# INLINEABLE insert #-}
136 insert (GET , a) r = r { resGet = Just a }
137 insert (HEAD , a) r = r { resHead = Just a }
138 insert (POST , a) r = r { resPost = Just a }
139 insert (PUT , a) r = r { resPut = Just a }
140 insert (DELETE, a) r = r { resDelete = Just a }
145 instance Foldable Resource (Method, Rsrc ()) where
146 {-# INLINEABLE foldMap #-}
147 foldMap f (Resource {..})
148 = maybe (∅) (f ∘ ((,) GET )) resGet ⊕
149 maybe (∅) (f ∘ ((,) HEAD )) resHead ⊕
150 maybe (∅) (f ∘ ((,) POST )) resPost ⊕
151 maybe (∅) (f ∘ ((,) PUT )) resPut ⊕
152 maybe (∅) (f ∘ ((,) DELETE)) resDelete
154 instance Collection Resource (Method, Rsrc ()) where
155 {-# INLINE filter #-}
156 filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
158 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
159 spawnRsrc (Resource {..}) ni@(NI {..})
160 = forkIO $ run `catch` processException
163 run = flip runRsrc ni $
165 fromMaybe notAllowed $ rsrc req
168 rsrc ∷ Request → Maybe (Rsrc ())
170 = case reqMethod req of
172 HEAD → case resHead of
178 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
181 notAllowed = do setStatus MethodNotAllowed
185 $ intersperse (A.toAsciiBuilder ", ")
186 $ map A.toAsciiBuilder allowedMethods
188 allowedMethods ∷ [Ascii]
189 allowedMethods = nub $ concat [ methods resGet ["GET"]
190 , methods resHead ["GET", "HEAD"]
191 , methods resPost ["POST"]
192 , methods resPut ["PUT"]
193 , methods resDelete ["DELETE"]
196 methods ∷ Maybe a → [Ascii] → [Ascii]
201 toAbortion ∷ SomeException → Abortion
203 = case fromException e of
204 Just abortion → abortion
205 Nothing → mkAbortion' InternalServerError $ T.pack $ show e
207 processException ∷ SomeException → IO ()
209 = do let abo = toAbortion exc
210 state ← atomically $ readTVar niState
211 res ← atomically $ readTVar niResponse
212 if state ≤ DecidingHeader then
213 -- We still have a chance to reflect this abortion
214 -- in the response. Hooray!
216 do setStatus $ aboStatus abo
217 mapM_ (uncurry setHeader) (aboHeaders abo)
218 setHeader "Content-Type" defaultPageContentType
219 deleteHeader "Content-Encoding"
220 putBuilder $ abortPage niConfig (Just niRequest) res abo
222 when (cnfDumpTooLateAbortionToStderr niConfig)
224 runRsrc (driftTo Done) ni
226 dumpAbortion ∷ Abortion → IO ()
229 $ concat [ "Lucu: an exception occured after "
230 , "sending the response header to the client:\n"
231 , " ", show abo, "\n"
234 getInteraction ∷ Rsrc NormalInteraction
235 getInteraction = Rsrc ask
237 -- |Get the 'Config' value for this httpd.
238 getConfig ∷ Rsrc Config
239 getConfig = niConfig <$> getInteraction
241 -- |Get the 'SockAddr' of the remote host.
242 getRemoteAddr ∷ Rsrc SockAddr
243 getRemoteAddr = niRemoteAddr <$> getInteraction
245 #if defined(HAVE_SSL)
246 -- | Return the X.509 certificate of the client, or 'Nothing' if:
248 -- * This request didn't came through an SSL stream.
250 -- * The client didn't send us its certificate.
252 -- * The 'OpenSSL.Session.VerificationMode' of
253 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
254 -- 'OpenSSL.Session.VerifyPeer'.
255 getRemoteCertificate ∷ Rsrc (Maybe X509)
256 getRemoteCertificate = niRemoteCert <$> getInteraction
259 -- |Return the 'Request' value representing the request header. You
260 -- usually don't need to call this function directly.
261 getRequest ∷ Rsrc Request
262 getRequest = niRequest <$> getInteraction
264 -- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
265 -- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
266 -- action is the exact path in the tree even when the 'Resource' is
267 -- 'Network.HTTP.Lucu.greedy'.
273 -- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
274 -- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
275 -- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
277 -- resFoo :: 'Resource'
278 -- resFoo = 'singleton'
280 -- , do requestURI <- 'getRequestURI'
281 -- resourcePath <- 'getResourcePath'
282 -- pathInfo <- 'getPathInfo'
283 -- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
284 -- -- resourcePath == ["foo"]
285 -- -- pathInfo == ["bar", "baz"]
289 getResourcePath ∷ Rsrc Path
290 getResourcePath = niResourcePath <$> getInteraction
292 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
293 -- bytes. You can incrementally read the request body by repeatedly
294 -- calling this function. If there is nothing to be read anymore,
295 -- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
296 -- /Deciding Header/ state.
297 getChunk ∷ Int → Rsrc ByteString
298 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
300 getChunk' ∷ Int → Rsrc ByteString
302 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
304 | otherwise = do req ← getRequest
305 if reqMustHaveBody req then
306 askForInput =≪ getInteraction
308 driftTo DecidingHeader *> return (∅)
310 askForInput ∷ NormalInteraction → Rsrc ByteString
311 askForInput (NI {..})
312 = do -- Ask the RequestReader to get a chunk.
314 $ putTMVar niReceiveBodyReq (ReceiveBody n)
315 -- Then wait for a reply.
318 $ takeTMVar niReceivedBody
319 -- Have we got an EOF?
321 $ driftTo DecidingHeader
324 -- |Declare the response status code. If you don't call this function,
325 -- the status code will be defaulted to \"200 OK\".
326 setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
328 = do ni ← getInteraction
330 $ do state ← readTVar $ niState ni
331 when (state > DecidingHeader)
332 $ fail "Too late to declare the response status."
333 res ← readTVar $ niResponse ni
334 writeTVar (niResponse ni) $ setStatusCode sc res
336 -- |@'setHeader' name value@ declares the value of the response header
337 -- @name@ as @value@. Note that this function is not intended to be
338 -- used so frequently: there should be specialised functions like
339 -- 'Network.HTTP.Lucu.setContentType' for every common headers.
341 -- Some important headers (especially \"Content-Length\" and
342 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
343 -- the system not to corrupt the interaction with client at the
344 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
345 -- the connection alive, without this manipulation it will be a
346 -- catastrophe when we send a header \"Content-Length: 10\" and
347 -- actually send a body of 20 bytes long to the remote peer. In this
348 -- case the client shall only accept the first 10 bytes of response
349 -- body and thinks that the residual 10 bytes is a part of the header
350 -- of the next response.
351 setHeader ∷ CIAscii → Ascii → Rsrc ()
352 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
354 go ∷ NormalInteraction → STM ()
356 = do state ← readTVar niState
357 when (state > DecidingHeader) $
358 fail "Too late to declare a response header field."
359 res ← readTVar niResponse
360 writeTVar niResponse $ H.setHeader name value res
361 when (name ≡ "Content-Type") $
362 writeTVar niResponseHasCType True
364 -- |@'deleteHeader' name@ deletes a response header @name@ if
365 -- any. This function is not intended to be used so frequently.
366 deleteHeader ∷ CIAscii → Rsrc ()
367 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
369 go ∷ NormalInteraction → STM ()
371 = do state ← readTVar niState
372 when (state > DecidingHeader) $
373 fail "Too late to delete a response header field."
374 res ← readTVar niResponse
375 writeTVar niResponse $ H.deleteHeader name res
376 when (name ≡ "Content-Type") $
377 writeTVar niResponseHasCType False
379 -- |Run a 'Builder' to construct a chunk, and write it to the response
380 -- body. It can be safely applied to a 'Builder' producing an
381 -- infinitely long stream of octets.
383 -- Note that you must first declare the response header
384 -- \"Content-Type\" before applying this function. See
385 -- 'Network.HTTP.Lucu.setContentType'.
386 putBuilder ∷ Builder → Rsrc ()
387 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
389 -- FIXME: should see if resCanHaveBody.
390 go ∷ NormalInteraction → STM ()
392 = do driftTo' ni SendingBody
393 hasCType ← readTVar niResponseHasCType
396 $ mkAbortion' InternalServerError
397 "putBuilder: Content-Type has not been set."
398 putTMVar niBodyToSend b
400 driftTo ∷ InteractionState → Rsrc ()
401 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
403 driftTo' ∷ NormalInteraction → InteractionState → STM ()
404 driftTo' ni@(NI {..}) newState
405 = do oldState ← readTVar niState
408 driftFrom ∷ InteractionState → STM ()
410 | newState < oldState = throwStateError oldState newState
411 | newState ≡ oldState = return ()
413 = do let a = [oldState .. newState]
416 mapM_ (uncurry driftFromTo) c
417 writeTVar niState newState
419 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
420 throwStateError Done SendingBody
421 = fail "It makes no sense to output something after finishing outputs."
422 throwStateError old new
423 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
425 driftFromTo ∷ InteractionState → InteractionState → STM ()
426 driftFromTo ReceivingBody _
427 = putTMVar niReceiveBodyReq WasteAll
428 driftFromTo DecidingHeader _