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.IO.Class
42 import Control.Monad.Reader (ReaderT, runReaderT, ask)
43 import Control.Monad.Unicode
44 import Data.Ascii (Ascii, CIAscii)
45 import qualified Data.Ascii as A
46 import Data.ByteString (ByteString)
47 import qualified Data.ByteString as BS
48 import Data.Collections
49 import Data.List (intersperse, nub)
52 import Data.Monoid.Unicode
53 import qualified Data.Text as T
54 import Network.HTTP.Lucu.Abortion
55 import Network.HTTP.Lucu.Abortion.Internal
56 import Network.HTTP.Lucu.Config
57 import Network.HTTP.Lucu.DefaultPage
58 import qualified Network.HTTP.Lucu.Headers as H
59 import Network.HTTP.Lucu.Interaction
60 import Network.HTTP.Lucu.Postprocess
61 import Network.HTTP.Lucu.Request
62 import Network.HTTP.Lucu.Response
63 import Network.HTTP.Lucu.Utils
68 import Prelude hiding (catch, concat, filter, mapM_, tail)
69 import Prelude.Unicode
72 -- |The resource monad. This monad implements 'MonadIO' so it can do
76 unRsrc ∷ ReaderT NormalInteraction IO a
78 deriving (Applicative, Functor, Monad, MonadIO)
80 runRsrc ∷ Rsrc a → NormalInteraction → IO a
81 runRsrc = runReaderT ∘ unRsrc
83 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
85 data Resource = Resource {
86 -- |A 'Rsrc' to be run when a GET request comes for the
87 -- resource path. If 'resGet' is Nothing, the system responds
88 -- \"405 Method Not Allowed\" for GET requests.
90 -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
91 -- that case 'putChunk' and such don't actually write a response
93 resGet ∷ !(Maybe (Rsrc ()))
94 -- |A 'Rsrc' to be run when a HEAD request comes for the
95 -- resource path. If 'resHead' is Nothing, the system runs
96 -- 'resGet' instead. If 'resGet' is also Nothing, the system
97 -- responds \"405 Method Not Allowed\" for HEAD requests.
98 , resHead ∷ !(Maybe (Rsrc ()))
99 -- |A 'Rsrc' to be run when a POST request comes for the
100 -- resource path. If 'resPost' is Nothing, the system responds
101 -- \"405 Method Not Allowed\" for POST requests.
102 , resPost ∷ !(Maybe (Rsrc ()))
103 -- |A 'Rsrc' to be run when a PUT request comes for the
104 -- resource path. If 'resPut' is Nothing, the system responds
105 -- \"405 Method Not Allowed\" for PUT requests.
106 , resPut ∷ !(Maybe (Rsrc ()))
107 -- |A 'Rsrc' to be run when a DELETE request comes for the
108 -- resource path. If 'resDelete' is Nothing, the system responds
109 -- \"405 Method Not Allowed\" for DELETE requests.
110 , resDelete ∷ !(Maybe (Rsrc ()))
113 instance Monoid Resource where
114 {-# INLINE mempty #-}
121 , resDelete = Nothing
123 {-# INLINEABLE mappend #-}
126 resGet = resGet a <|> resGet b
127 , resHead = resHead a <|> resHead b
128 , resPost = resPost a <|> resPost b
129 , resPut = resPut a <|> resPut b
130 , resDelete = resDelete a <|> resDelete b
133 instance Unfoldable Resource (Method, Rsrc ()) where
134 {-# INLINEABLE insert #-}
135 insert (GET , a) r = r { resGet = Just a }
136 insert (HEAD , a) r = r { resHead = Just a }
137 insert (POST , a) r = r { resPost = Just a }
138 insert (PUT , a) r = r { resPut = Just a }
139 insert (DELETE, a) r = r { resDelete = Just a }
144 instance Foldable Resource (Method, Rsrc ()) where
145 {-# INLINEABLE foldMap #-}
146 foldMap f (Resource {..})
147 = maybe (∅) (f ∘ ((,) GET )) resGet ⊕
148 maybe (∅) (f ∘ ((,) HEAD )) resHead ⊕
149 maybe (∅) (f ∘ ((,) POST )) resPost ⊕
150 maybe (∅) (f ∘ ((,) PUT )) resPut ⊕
151 maybe (∅) (f ∘ ((,) DELETE)) resDelete
153 instance Collection Resource (Method, Rsrc ()) where
154 {-# INLINE filter #-}
155 filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
157 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
158 spawnRsrc (Resource {..}) ni@(NI {..})
159 = forkIO $ run `catch` processException
162 run = flip runRsrc ni $
164 fromMaybe notAllowed $ rsrc req
167 rsrc ∷ Request → Maybe (Rsrc ())
169 = case reqMethod req of
171 HEAD → case resHead of
177 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
180 notAllowed = do setStatus MethodNotAllowed
184 $ intersperse (A.toAsciiBuilder ", ")
185 $ map A.toAsciiBuilder allowedMethods
187 allowedMethods ∷ [Ascii]
188 allowedMethods = nub $ concat [ methods resGet ["GET"]
189 , methods resHead ["GET", "HEAD"]
190 , methods resPost ["POST"]
191 , methods resPut ["PUT"]
192 , methods resDelete ["DELETE"]
195 methods ∷ Maybe a → [Ascii] → [Ascii]
200 toAbortion ∷ SomeException → Abortion
202 = case fromException e of
203 Just abortion → abortion
204 Nothing → mkAbortion' InternalServerError $ T.pack $ show e
206 processException ∷ SomeException → IO ()
208 = do let abo = toAbortion exc
209 state ← atomically $ readTVar niState
210 res ← atomically $ readTVar niResponse
211 if state ≤ DecidingHeader then
212 -- We still have a chance to reflect this abortion
213 -- in the response. Hooray!
215 do setStatus $ aboStatus abo
216 mapM_ (uncurry setHeader) (aboHeaders abo)
217 setHeader "Content-Type" defaultPageContentType
218 deleteHeader "Content-Encoding"
219 putBuilder $ abortPage niConfig (Just niRequest) res abo
221 when (cnfDumpTooLateAbortionToStderr niConfig)
223 runRsrc (driftTo Done) ni
225 dumpAbortion ∷ Abortion → IO ()
228 $ concat [ "Lucu: an exception occured after "
229 , "sending the response header to the client:\n"
230 , " ", show abo, "\n"
233 getInteraction ∷ Rsrc NormalInteraction
234 getInteraction = Rsrc ask
236 -- |Get the 'Config' value for this httpd.
237 getConfig ∷ Rsrc Config
238 getConfig = niConfig <$> getInteraction
240 -- |Get the 'SockAddr' of the remote host.
241 getRemoteAddr ∷ Rsrc SockAddr
242 getRemoteAddr = niRemoteAddr <$> getInteraction
244 #if defined(HAVE_SSL)
245 -- | Return the X.509 certificate of the client, or 'Nothing' if:
247 -- * This request didn't came through an SSL stream.
249 -- * The client didn't send us its certificate.
251 -- * The 'OpenSSL.Session.VerificationMode' of
252 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
253 -- 'OpenSSL.Session.VerifyPeer'.
254 getRemoteCertificate ∷ Rsrc (Maybe X509)
255 getRemoteCertificate = niRemoteCert <$> getInteraction
258 -- |Return the 'Request' value representing the request header. You
259 -- usually don't need to call this function directly.
260 getRequest ∷ Rsrc Request
261 getRequest = niRequest <$> getInteraction
263 -- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
264 -- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
265 -- action is the exact path in the tree even when the 'Resource' is
266 -- 'Network.HTTP.Lucu.greedy'.
272 -- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
273 -- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
274 -- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
276 -- resFoo :: 'Resource'
277 -- resFoo = 'singleton'
279 -- , do requestURI <- 'getRequestURI'
280 -- resourcePath <- 'getResourcePath'
281 -- pathInfo <- 'getPathInfo'
282 -- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
283 -- -- resourcePath == ["foo"]
284 -- -- pathInfo == ["bar", "baz"]
288 getResourcePath ∷ Rsrc Path
289 getResourcePath = niResourcePath <$> getInteraction
291 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
292 -- bytes. You can incrementally read the request body by repeatedly
293 -- calling this function. If there is nothing to be read anymore,
294 -- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
295 -- /Deciding Header/ state.
296 getChunk ∷ Int → Rsrc ByteString
297 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
299 getChunk' ∷ Int → Rsrc ByteString
301 | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
303 | otherwise = do req ← getRequest
304 if reqMustHaveBody req then
305 askForInput =≪ getInteraction
307 driftTo DecidingHeader *> return (∅)
309 askForInput ∷ NormalInteraction → Rsrc ByteString
310 askForInput (NI {..})
311 = do -- Ask the RequestReader to get a chunk.
313 $ putTMVar niReceiveBodyReq (ReceiveBody n)
314 -- Then wait for a reply.
317 $ takeTMVar niReceivedBody
318 -- Have we got an EOF?
320 $ driftTo DecidingHeader
323 -- |Declare the response status code. If you don't call this function,
324 -- the status code will be defaulted to \"200 OK\".
325 setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
327 = do ni ← getInteraction
329 $ do state ← readTVar $ niState ni
330 when (state > DecidingHeader)
331 $ fail "Too late to declare the response status."
332 res ← readTVar $ niResponse ni
333 writeTVar (niResponse ni) $ setStatusCode sc res
335 -- |@'setHeader' name value@ declares the value of the response header
336 -- @name@ as @value@. Note that this function is not intended to be
337 -- used so frequently: there should be specialised functions like
338 -- 'Network.HTTP.Lucu.setContentType' for every common headers.
340 -- Some important headers (especially \"Content-Length\" and
341 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
342 -- the system not to corrupt the interaction with client at the
343 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
344 -- the connection alive, without this manipulation it will be a
345 -- catastrophe when we send a header \"Content-Length: 10\" and
346 -- actually send a body of 20 bytes long to the remote peer. In this
347 -- case the client shall only accept the first 10 bytes of response
348 -- body and thinks that the residual 10 bytes is a part of the header
349 -- of the next response.
350 setHeader ∷ CIAscii → Ascii → Rsrc ()
351 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
353 go ∷ NormalInteraction → STM ()
355 = do state ← readTVar niState
356 when (state > DecidingHeader) $
357 fail "Too late to declare a response header field."
358 res ← readTVar niResponse
359 writeTVar niResponse $ H.setHeader name value res
360 when (name ≡ "Content-Type") $
361 writeTVar niResponseHasCType True
363 -- |@'deleteHeader' name@ deletes a response header @name@ if
364 -- any. This function is not intended to be used so frequently.
365 deleteHeader ∷ CIAscii → Rsrc ()
366 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
368 go ∷ NormalInteraction → STM ()
370 = do state ← readTVar niState
371 when (state > DecidingHeader) $
372 fail "Too late to delete a response header field."
373 res ← readTVar niResponse
374 writeTVar niResponse $ H.deleteHeader name res
375 when (name ≡ "Content-Type") $
376 writeTVar niResponseHasCType False
378 -- |Run a 'Builder' to construct a chunk, and write it to the response
379 -- body. It can be safely applied to a 'Builder' producing an
380 -- infinitely long stream of octets.
382 -- Note that you must first declare the response header
383 -- \"Content-Type\" before applying this function. See
384 -- 'Network.HTTP.Lucu.setContentType'.
385 putBuilder ∷ Builder → Rsrc ()
386 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
388 -- FIXME: should see if resCanHaveBody.
389 go ∷ NormalInteraction → STM ()
391 = do driftTo' ni SendingBody
392 hasCType ← readTVar niResponseHasCType
395 $ mkAbortion' InternalServerError
396 "putBuilder: Content-Type has not been set."
397 putTMVar niBodyToSend b
399 driftTo ∷ InteractionState → Rsrc ()
400 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
402 driftTo' ∷ NormalInteraction → InteractionState → STM ()
403 driftTo' ni@(NI {..}) newState
404 = do oldState ← readTVar niState
407 driftFrom ∷ InteractionState → STM ()
409 | newState < oldState = throwStateError oldState newState
410 | newState ≡ oldState = return ()
412 = do let a = [oldState .. newState]
415 mapM_ (uncurry driftFromTo) c
416 writeTVar niState newState
418 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
419 throwStateError Done SendingBody
420 = fail "It makes no sense to output something after finishing outputs."
421 throwStateError old new
422 = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
424 driftFromTo ∷ InteractionState → InteractionState → STM ()
425 driftFromTo ReceivingBody _
426 = putTMVar niReceiveBodyReq WasteAll
427 driftFromTo DecidingHeader _