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