]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Resource/Tree.hs
b45707249062c143d39270da8a45d9aaaa1814b6
[Lucu.git] / Network / HTTP / Lucu / Resource / Tree.hs
1 {-# LANGUAGE
2     DoAndIfThenElse
3   , OverloadedStrings
4   , UnicodeSyntax
5   #-}
6 {-# OPTIONS_HADDOCK prune #-}
7
8 -- | Repository of the resources in httpd.
9 module Network.HTTP.Lucu.Resource.Tree
10     ( ResourceDef(..)
11     , emptyResource
12
13     , ResTree
14     , FallbackHandler
15
16     , mkResTree
17
18     , findResource
19     , runResource
20     )
21     where
22 import           Control.Arrow
23 import Control.Applicative
24 import Data.Ascii (Ascii)
25 import qualified Data.Ascii as A
26 import           Control.Concurrent
27 import           Control.Concurrent.STM
28 import           Control.Exception
29 import           Control.Monad
30 import Data.Text (Text)
31 import qualified Data.Text as T
32 import qualified Data.Text.Lazy.Encoding as LT
33 import           Data.List
34 import qualified Data.Map as M
35 import           Data.Map (Map)
36 import           Data.Maybe
37 import Data.Monoid.Unicode
38 import           Network.HTTP.Lucu.Abortion
39 import           Network.HTTP.Lucu.Config
40 import           Network.HTTP.Lucu.Headers (fromHeaders)
41 import           Network.HTTP.Lucu.Request
42 import           Network.HTTP.Lucu.Resource
43 import           Network.HTTP.Lucu.Response
44 import           Network.HTTP.Lucu.Interaction
45 import           Network.HTTP.Lucu.Utils
46 import           Network.URI hiding (path)
47 import           System.IO
48 import           Prelude hiding (catch)
49 import Prelude.Unicode
50
51
52 -- |'FallbackHandler' is an extra resource handler for resources which
53 -- can't be statically located anywhere in the resource tree. The Lucu
54 -- httpd first searches for a resource in the tree, and then calls
55 -- fallback handlers to ask them for a resource. If all of the
56 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
57 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
58
59
60 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
61 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
62 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
63 -- 無視される。
64
65 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
66 -- HTTP methods.
67 data ResourceDef = ResourceDef {
68     -- |Whether to run a 'Resource' on a native thread (spawned by
69     -- 'forkOS') or to run it on a user thread (spanwed by
70     -- 'forkIO'). Generally you don't need to set this field to
71     -- 'True'.
72       resUsesNativeThread ∷ !Bool
73     -- | Whether to be greedy or not.
74     -- 
75     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
76     -- greedy resource at \/aaa\/bbb, it is always chosen even if
77     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
78     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
79     -- resources are like CGI scripts.
80     , resIsGreedy         ∷ !Bool
81     -- | A 'Resource' to be run when a GET request comes for the
82     -- resource path. If 'resGet' is Nothing, the system responds
83     -- \"405 Method Not Allowed\" for GET requests.
84     -- 
85     -- It also runs for HEAD request if the 'resHead' is Nothing. In
86     -- this case 'output' and such like don't actually write a
87     -- response body.
88     , resGet              ∷ !(Maybe (Resource ()))
89     -- | A 'Resource' to be run when a HEAD request comes for the
90     -- resource path. If 'resHead' is Nothing, the system runs
91     -- 'resGet' instead. If 'resGet' is also Nothing, the system
92     -- responds \"405 Method Not Allowed\" for HEAD requests.
93     , resHead             ∷ !(Maybe (Resource ()))
94     -- | A 'Resource' to be run when a POST request comes for the
95     -- resource path. If 'resPost' is Nothing, the system responds
96     -- \"405 Method Not Allowed\" for POST requests.
97     , resPost             ∷ !(Maybe (Resource ()))
98     -- | A 'Resource' to be run when a PUT request comes for the
99     -- resource path. If 'resPut' is Nothing, the system responds
100     -- \"405 Method Not Allowed\" for PUT requests.
101     , resPut              ∷ !(Maybe (Resource ()))
102     -- | A 'Resource' to be run when a DELETE request comes for the
103     -- resource path. If 'resDelete' is Nothing, the system responds
104     -- \"405 Method Not Allowed\" for DELETE requests.
105     , resDelete           ∷ !(Maybe (Resource ()))
106     }
107
108 -- |'emptyResource' is a resource definition with no actual
109 -- handlers. You can construct a 'ResourceDef' by selectively
110 -- overriding 'emptyResource'. It is defined as follows:
111 --
112 -- @
113 --   emptyResource = ResourceDef {
114 --                     resUsesNativeThread = False
115 --                   , resIsGreedy         = False
116 --                   , resGet              = Nothing
117 --                   , resHead             = Nothing
118 --                   , resPost             = Nothing
119 --                   , resPut              = Nothing
120 --                   , resDelete           = Nothing
121 --                   }
122 -- @
123 emptyResource ∷ ResourceDef
124 emptyResource = ResourceDef {
125                   resUsesNativeThread = False
126                 , resIsGreedy         = False
127                 , resGet              = Nothing
128                 , resHead             = Nothing
129                 , resPost             = Nothing
130                 , resPut              = Nothing
131                 , resDelete           = Nothing
132                 }
133
134 -- |'ResTree' is an opaque structure which is a map from resource path
135 -- to 'ResourceDef'.
136 newtype ResTree = ResTree ResNode -- root だから Map ではない
137 type ResSubtree = Map Text ResNode
138 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
139
140 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
141 --
142 -- @
143 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
144 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
145 --             ]
146 -- @
147 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
148 mkResTree = processRoot . map (first canonicalisePath)
149     where
150       canonicalisePath ∷ [Text] → [Text]
151       canonicalisePath = filter (≢ "")
152
153       processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
154       processRoot list
155           = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
156                 children = processNonRoot nonRoots
157             in
158               if null roots then
159                   -- The root has no resources. Maybe there's one at
160                   -- somewhere like "/foo".
161                   ResTree (ResNode Nothing children)
162               else
163                   -- There is a root resource.
164                   let (_, def) = last roots
165                   in 
166                     ResTree (ResNode (Just def) children)
167
168       processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
169       processNonRoot list
170           = let subtree    = M.fromList [(name, node name)
171                                              | name ← childNames]
172                 childNames = [name | (name:_, _) ← list]
173                 node name  = let defs = [def | (path, def) ← list, path == [name]]
174                              in
175                                if null defs then
176                                    -- No resources are defined
177                                    -- here. Maybe there's one at
178                                    -- somewhere below this node.
179                                    ResNode Nothing children
180                                else
181                                    -- There is a resource here.
182                                    ResNode (Just $ last defs) children
183                 children   = processNonRoot [(path, def)
184                                                  | (_:path, def) ← list]
185             in
186               subtree
187
188
189 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
190 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
191     = do let path           = splitPathInfo uri
192              haveGreedyRoot = case rootDefM of
193                                 Just def → resIsGreedy def
194                                 Nothing  → False
195              foundInTree    = if haveGreedyRoot ∨ null path then
196                                   do def ← rootDefM
197                                      return ([], def)
198                               else
199                                   walkTree subtree path []
200          if isJust foundInTree then
201              return foundInTree
202          else
203              fallback path fbs
204     where
205       walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
206
207       walkTree _ [] _
208           = error "Internal error: should not reach here."
209
210       walkTree tree (name:[]) soFar
211           = case M.lookup name tree of
212               Nothing               → Nothing
213               Just (ResNode defM _) → do def ← defM
214                                          return (soFar ⧺ [name], def)
215
216       walkTree tree (x:xs) soFar
217           = case M.lookup x tree of
218               Nothing                      → Nothing
219               Just (ResNode defM children) → case defM of
220                                                 Just (ResourceDef { resIsGreedy = True })
221                                                     → do def ← defM
222                                                          return (soFar ++ [x], def)
223                                                 _   → walkTree children xs (soFar ++ [x])
224
225       fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
226       fallback _    []     = return Nothing
227       fallback path (x:xs) = do m ← x path
228                                 case m of
229                                   Just def → return $! Just ([], def)
230                                   Nothing  → fallback path xs
231
232
233 runResource ∷ ResourceDef → Interaction → IO ThreadId
234 runResource def itr
235     = def `seq` itr `seq`
236       fork
237       $! catch ( runRes ( do req ← getRequest
238                              fromMaybe notAllowed $ rsrc req
239                              driftTo Done
240                         ) itr
241                )
242                processException
243     where
244       fork ∷ IO () → IO ThreadId
245       fork = if resUsesNativeThread def
246              then forkOS
247              else forkIO
248       
249       rsrc ∷ Request → Maybe (Resource ())
250       rsrc req
251           = case reqMethod req of
252               GET    → resGet def
253               HEAD   → case resHead def of
254                           Just r  → Just r
255                           Nothing → resGet def
256               POST   → resPost def
257               PUT    → resPut def
258               DELETE → resDelete def
259               _      → undefined
260
261       notAllowed ∷ Resource ()
262       notAllowed
263           = setStatus MethodNotAllowed
264             *>
265             (setHeader "Allow" $ A.fromAsciiBuilder
266                                $ joinWith ", "
267                                $ map A.toAsciiBuilder allowedMethods)
268
269       allowedMethods ∷ [Ascii]
270       allowedMethods = nub $ concat [ methods resGet    ["GET"]
271                                     , methods resHead   ["GET", "HEAD"]
272                                     , methods resPost   ["POST"]
273                                     , methods resPut    ["PUT"]
274                                     , methods resDelete ["DELETE"]
275                                     ]
276
277       methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii]
278       methods f xs = case f def of
279                        Just _  → xs
280                        Nothing → []
281
282       toAbortion ∷ SomeException → Abortion
283       toAbortion e
284           = case fromException e of
285               Just abortion → abortion
286               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
287
288       processException ∷ SomeException → IO ()
289       processException exc
290           = do let abo = toAbortion exc
291                    conf = itrConfig itr
292                -- まだ DecidingHeader 以前の状態だったら、この途中終了
293                -- を應答に反映させる餘地がある。さうでなければ stderr
294                -- にでも吐くしか無い。
295                state ← atomically $ readItr itrState    id itr
296                reqM  ← atomically $ readItr itrRequest  id itr
297                res   ← atomically $ readItr itrResponse id itr
298                if state ≤ DecidingHeader then
299                    flip runRes itr
300                       $ do setStatus $ aboStatus abo
301                            mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
302                            output $ LT.encodeUtf8 $ abortPage conf reqM res abo
303                  else
304                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
305                             $ hPutStrLn stderr $ show abo
306
307                flip runRes itr $ driftTo Done