]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Resource/Internal.hs
Code clean-up using convertible-text.
[Lucu.git] / Network / HTTP / Lucu / Resource / Internal.hs
1 {-# LANGUAGE
2     CPP
3   , DoAndIfThenElse
4   , FlexibleInstances
5   , GeneralizedNewtypeDeriving
6   , OverloadedStrings
7   , MultiParamTypeClasses
8   , RecordWildCards
9   , UnicodeSyntax
10   #-}
11 module Network.HTTP.Lucu.Resource.Internal
12     ( Rsrc
13     , Resource(..)
14     , spawnRsrc
15
16     , getConfig
17     , getRemoteAddr
18 #if defined(HAVE_SSL)
19     , getRemoteCertificate
20 #endif
21     , getRequest
22     , getResourcePath
23
24     , getChunk
25
26     , setStatus
27     , setHeader
28     , deleteHeader
29
30     , putBuilder
31
32     , driftTo
33     )
34     where
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)
52 import Data.Maybe
53 import Data.Monoid
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.Utils
65 import Network.Socket
66 #if defined(HAVE_SSL)
67 import OpenSSL.X509
68 #endif
69 import Prelude hiding (catch, concat, filter, mapM_, tail)
70 import Prelude.Unicode
71 import System.IO
72
73 -- |The resource monad. This monad implements 'MonadIO' so it can do
74 -- any 'IO' actions.
75 newtype Rsrc a
76     = Rsrc {
77         unRsrc ∷ ReaderT NormalInteraction IO a
78       }
79     deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
80
81 runRsrc ∷ Rsrc a → NormalInteraction → IO a
82 runRsrc = runReaderT ∘ unRsrc
83
84 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
85 -- each HTTP methods.
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.
90     --
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
93     -- body.
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 ()))
112     }
113
114 instance Monoid Resource where
115     {-# INLINE mempty #-}
116     mempty
117         = Resource {
118             resGet    = Nothing
119           , resHead   = Nothing
120           , resPost   = Nothing
121           , resPut    = Nothing
122           , resDelete = Nothing
123           }
124     {-# INLINEABLE mappend #-}
125     mappend a b
126         = Resource {
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
132           }
133
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 }
141     insert _           r = r
142     {-# INLINE empty #-}
143     empty = (∅)
144
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
153
154 instance Collection Resource (Method, Rsrc ()) where
155     {-# INLINE filter #-}
156     filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
157
158 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
159 spawnRsrc (Resource {..}) ni@(NI {..})
160     = forkIO $ run `catch` processException
161     where
162       run ∷ IO ()
163       run = flip runRsrc ni $
164             do req ← getRequest
165                fromMaybe notAllowed $ rsrc req
166                driftTo Done
167
168       rsrc ∷ Request → Maybe (Rsrc ())
169       rsrc req
170           = case reqMethod req of
171               GET    → resGet
172               HEAD   → case resHead of
173                           Just r  → Just r
174                           Nothing → resGet
175               POST   → resPost
176               PUT    → resPut
177               DELETE → resDelete
178               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
179
180       notAllowed ∷ Rsrc ()
181       notAllowed = do setStatus MethodNotAllowed
182                       setHeader "Allow"
183                           $ cs
184                           $ mconcat
185                           $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
186                           $ map cs allowedMethods
187
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"]
194                                     ]
195
196       methods ∷ Maybe a → [Ascii] → [Ascii]
197       methods m xs
198           | isJust m  = xs
199           | otherwise = []
200
201       toAbortion ∷ SomeException → Abortion
202       toAbortion e
203           = case fromException e of
204               Just abortion → abortion
205               Nothing       → mkAbortion' InternalServerError $ cs $ show e
206
207       processException ∷ SomeException → IO ()
208       processException exc
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!
215                    flip runRsrc ni $
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
221                else
222                    when (cnfDumpTooLateAbortionToStderr niConfig)
223                        $ dumpAbortion abo
224                runRsrc (driftTo Done) ni
225
226 dumpAbortion ∷ Abortion → IO ()
227 dumpAbortion abo
228     = hPutStr stderr
229       $ concat [ "Lucu: an exception occured after "
230                , "sending the response header to the client:\n"
231                , "  ", show abo, "\n"
232                ]
233
234 getInteraction ∷ Rsrc NormalInteraction
235 getInteraction = Rsrc ask
236
237 -- |Get the 'Config' value for this httpd.
238 getConfig ∷ Rsrc Config
239 getConfig = niConfig <$> getInteraction
240
241 -- |Get the 'SockAddr' of the remote host.
242 getRemoteAddr ∷ Rsrc SockAddr
243 getRemoteAddr = niRemoteAddr <$> getInteraction
244
245 #if defined(HAVE_SSL)
246 -- | Return the X.509 certificate of the client, or 'Nothing' if:
247 --
248 --   * This request didn't came through an SSL stream.
249 --
250 --   * The client didn't send us its certificate.
251 --
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
257 #endif
258
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
263
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'.
268 --
269 -- Example:
270 --
271 -- @
272 --   main :: 'IO' ()
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
276 --
277 --   resFoo :: 'Resource'
278 --   resFoo = 'singleton'
279 --            ( 'GET'
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"]
286 --                 ...
287 --            )
288 -- @
289 getResourcePath ∷ Rsrc Path
290 getResourcePath = niResourcePath <$> getInteraction
291
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'
299
300 getChunk' ∷ Int → Rsrc ByteString
301 getChunk' n
302     | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
303     | n ≡ 0     = return (∅)
304     | otherwise = do req ← getRequest
305                      if reqMustHaveBody req then
306                          askForInput =≪ getInteraction
307                      else
308                          driftTo DecidingHeader *> return (∅)
309     where
310       askForInput ∷ NormalInteraction → Rsrc ByteString
311       askForInput (NI {..})
312           = do -- Ask the RequestReader to get a chunk.
313                liftIO $ atomically
314                       $ putTMVar niReceiveBodyReq (ReceiveBody n)
315                -- Then wait for a reply.
316                chunk ← liftIO
317                        $ atomically
318                        $ takeTMVar niReceivedBody
319                -- Have we got an EOF?
320                when (BS.null chunk)
321                    $ driftTo DecidingHeader
322                return chunk
323
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 ()
327 setStatus sc
328     = do ni ← getInteraction
329          liftIO $ atomically
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
335
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.
340 --
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
353     where
354       go ∷ NormalInteraction → STM ()
355       go (NI {..})
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
363
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
368     where
369       go ∷ NormalInteraction → STM ()
370       go (NI {..})
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
378
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.
382 --
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
388     where
389       -- FIXME: should see if resCanHaveBody.
390       go ∷ NormalInteraction → STM ()
391       go ni@(NI {..})
392           = do driftTo' ni SendingBody
393                hasCType ← readTVar niResponseHasCType
394                unless hasCType
395                    $ throwSTM
396                    $ mkAbortion' InternalServerError
397                      "putBuilder: Content-Type has not been set."
398                putTMVar niBodyToSend b
399
400 driftTo ∷ InteractionState → Rsrc ()
401 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
402
403 driftTo' ∷ NormalInteraction → InteractionState → STM ()
404 driftTo' ni@(NI {..}) newState
405     = do oldState ← readTVar niState
406          driftFrom oldState
407     where
408       driftFrom ∷ InteractionState → STM ()
409       driftFrom oldState
410           | newState < oldState = throwStateError oldState newState
411           | newState ≡ oldState = return ()
412           | otherwise
413               = do let a = [oldState .. newState]
414                        b = tail a
415                        c = zip a b
416                    mapM_ (uncurry driftFromTo) c
417                    writeTVar niState newState
418
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)
424
425       driftFromTo ∷ InteractionState → InteractionState → STM ()
426       driftFromTo ReceivingBody _
427           = putTMVar niReceiveBodyReq WasteAll
428       driftFromTo DecidingHeader _
429           = postprocess ni
430       driftFromTo _ _
431           = return ()