1 {-# OPTIONS_HADDOCK prune #-}
3 -- | Repository of the resources in httpd.
4 module Network.HTTP.Lucu.Resource.Tree
11 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
13 , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
14 , runResource -- ResourceDef -> Interaction -> IO ThreadId
19 import Control.Concurrent
20 import Control.Concurrent.STM
21 import Control.Exception
23 import qualified Data.ByteString.Char8 as C8
25 import qualified Data.Map as M
28 import Network.HTTP.Lucu.Abortion
29 import Network.HTTP.Lucu.Config
30 import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders)
31 import Network.HTTP.Lucu.Request
32 import Network.HTTP.Lucu.Resource
33 import Network.HTTP.Lucu.Response
34 import Network.HTTP.Lucu.Interaction
35 import Network.HTTP.Lucu.Utils
36 import Network.URI hiding (path)
38 import Prelude hiding (catch)
41 -- |'FallbackHandler' is an extra resource handler for resources which
42 -- can't be statically located somewhere in the resource tree. The
43 -- Lucu httpd first search for a resource in the tree, and then call
44 -- fallback handlers to ask them for a resource. If all of the
45 -- handlers returned 'Prelude.Nothing', the httpd responds with 404
47 type FallbackHandler = [String] -> IO (Maybe ResourceDef)
50 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
51 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
52 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
55 -- | 'ResourceDef' is basically a set of
56 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
57 data ResourceDef = ResourceDef {
58 -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
59 -- native thread (spawned by 'Control.Concurrent.forkOS') or to
60 -- run it on a user thread (spanwed by
61 -- 'Control.Concurrent.forkIO'). Generally you don't need to set
62 -- this field to 'Prelude.True'.
63 resUsesNativeThread :: !Bool
64 -- | Whether to be greedy or not.
66 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
67 -- greedy resource at \/aaa\/bbb, it is always chosen even if
68 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
69 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
70 -- resources are like CGI scripts.
71 , resIsGreedy :: !Bool
72 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
73 -- request comes for the resource path. If 'resGet' is Nothing,
74 -- the system responds \"405 Method Not Allowed\" for GET
77 -- It also runs for HEAD request if the 'resHead' is Nothing. In
78 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
79 -- don't actually write a response body.
80 , resGet :: !(Maybe (Resource ()))
81 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
82 -- request comes for the resource path. If 'resHead' is Nothing,
83 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
84 -- the system responds \"405 Method Not Allowed\" for HEAD
86 , resHead :: !(Maybe (Resource ()))
87 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
88 -- request comes for the resource path. If 'resPost' is Nothing,
89 -- the system responds \"405 Method Not Allowed\" for POST
91 , resPost :: !(Maybe (Resource ()))
92 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
93 -- request comes for the resource path. If 'resPut' is Nothing,
94 -- the system responds \"405 Method Not Allowed\" for PUT
96 , resPut :: !(Maybe (Resource ()))
97 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
98 -- DELETE request comes for the resource path. If 'resDelete' is
99 -- Nothing, the system responds \"405 Method Not Allowed\" for
101 , resDelete :: !(Maybe (Resource ()))
104 -- |'emptyResource' is a resource definition with no actual
105 -- handlers. You can construct a 'ResourceDef' by selectively
106 -- overriding 'emptyResource'. It is defined as follows:
109 -- emptyResource = ResourceDef {
110 -- resUsesNativeThread = False
111 -- , resIsGreedy = False
112 -- , resGet = Nothing
113 -- , resHead = Nothing
114 -- , resPost = Nothing
115 -- , resPut = Nothing
116 -- , resDelete = Nothing
119 emptyResource :: ResourceDef
120 emptyResource = ResourceDef {
121 resUsesNativeThread = False
122 , resIsGreedy = False
127 , resDelete = Nothing
130 -- |'ResTree' is an opaque structure which is a map from resource path
132 newtype ResTree = ResTree ResNode -- root だから Map ではない
133 type ResSubtree = Map String ResNode
134 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
136 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
139 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
140 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
143 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
144 mkResTree = processRoot . map (first canonicalisePath)
146 canonicalisePath :: [String] -> [String]
147 canonicalisePath = filter (/= "")
149 processRoot :: [ ([String], ResourceDef) ] -> ResTree
151 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
152 children = processNonRoot nonRoots
155 -- The root has no resources. Maybe there's one at
156 -- somewhere like "/foo".
157 ResTree (ResNode Nothing children)
159 -- There is a root resource.
160 let (_, def) = last roots
162 ResTree (ResNode (Just def) children)
164 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
166 = let subtree = M.fromList [(name, node name)
167 | name <- childNames]
168 childNames = [name | (name:_, _) <- list]
169 node name = let defs = [def | (path, def) <- list, path == [name]]
172 -- No resources are defined
173 -- here. Maybe there's one at
174 -- somewhere below this node.
175 ResNode Nothing children
177 -- There is a resource here.
178 ResNode (Just $ last defs) children
179 children = processNonRoot [(path, def)
180 | (_:path, def) <- list]
185 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
186 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
187 = do let pathStr = uriPath uri
188 path = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""]
189 haveGreedyRoot = case rootDefM of
190 Just def -> resIsGreedy def
192 foundInTree = if haveGreedyRoot || null path then
196 walkTree subtree path []
197 if isJust foundInTree then
202 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
205 = error "Internal error: should not reach here."
207 walkTree tree (name:[]) soFar
208 = case M.lookup name tree of
210 Just (ResNode defM _) -> do def <- defM
211 return (soFar ++ [name], def)
213 walkTree tree (x:xs) soFar
214 = case M.lookup x tree of
216 Just (ResNode defM children) -> case defM of
217 Just (ResourceDef { resIsGreedy = True })
219 return (soFar ++ [x], def)
220 _ -> walkTree children xs (soFar ++ [x])
222 fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
223 fallback _ [] = return Nothing
224 fallback path (x:xs) = do m <- x path
226 Just def -> return $! Just ([], def)
227 Nothing -> fallback path xs
230 runResource :: ResourceDef -> Interaction -> IO ThreadId
232 = def `seq` itr `seq`
234 $! catch ( runRes ( do req <- getRequest
235 fromMaybe notAllowed $ rsrc req
241 fork :: IO () -> IO ThreadId
242 fork = if resUsesNativeThread def
246 rsrc :: Request -> Maybe (Resource ())
248 = case reqMethod req of
250 HEAD -> case resHead def of
252 Nothing -> resGet def
255 DELETE -> resDelete def
258 notAllowed :: Resource ()
259 notAllowed = do setStatus MethodNotAllowed
260 setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
262 allowedMethods :: [String]
263 allowedMethods = nub $ concat [ methods resGet ["GET"]
264 , methods resHead ["GET", "HEAD"]
265 , methods resPost ["POST"]
266 , methods resPut ["PUT"]
267 , methods resDelete ["DELETE"]
270 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
271 methods f xs = case f def of
275 toAbortion :: SomeException -> Abortion
276 toAbortion e = case fromException e of
277 Just abortion -> abortion
278 Nothing -> Abortion InternalServerError emptyHeaders (Just (show e))
280 processException :: SomeException -> IO ()
282 = do let abo = toAbortion exc
284 -- まだ DecidingHeader 以前の状態だったら、この途中終了
285 -- を應答に反映させる餘地がある。さうでなければ stderr
287 state <- atomically $ readItr itr itrState id
288 reqM <- atomically $ readItr itr itrRequest id
289 res <- atomically $ readItr itr itrResponse id
290 if state <= DecidingHeader then
292 $ do setStatus $ aboStatus abo
293 mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
294 output $ abortPage conf reqM res abo
296 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
297 $ hPutStrLn stderr $ show abo
299 flip runRes itr $ driftTo Done