1 {-# OPTIONS_HADDOCK prune #-}
3 -- | Repository of the resources in httpd.
4 module Network.HTTP.Lucu.Resource.Tree
9 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
11 , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
12 , runResource -- ResourceDef -> Interaction -> IO ThreadId
16 import Control.Concurrent
17 import Control.Concurrent.STM
18 import Control.Exception
20 import qualified Data.ByteString.Char8 as C8
22 import qualified Data.Map as M
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)
35 import System.IO.Error hiding (catch)
36 import Prelude hiding (catch)
39 -- |'FallbackHandler' is an extra resource handler for resources which
40 -- can't be statically located somewhere in the resource tree. The
41 -- Lucu httpd first search for a resource in the tree, and then call
42 -- fallback handlers to ask them for a resource. If all of the
43 -- handlers returned 'Prelude.Nothing', the httpd responds with 404
45 type FallbackHandler = [String] -> IO (Maybe ResourceDef)
48 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
49 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
50 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
53 -- | 'ResourceDef' is basically a set of
54 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
55 data ResourceDef = ResourceDef {
56 -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
57 -- native thread (spawned by 'Control.Concurrent.forkOS') or to
58 -- run it on a user thread (spanwed by
59 -- 'Control.Concurrent.forkIO'). Generally you don't need to set
60 -- this field to 'Prelude.True'.
61 resUsesNativeThread :: !Bool
62 -- | Whether to be greedy or not.
64 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
65 -- greedy resource at \/aaa\/bbb, it is always chosen even if
66 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
67 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
68 -- resources are like CGI scripts.
69 , resIsGreedy :: !Bool
70 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
71 -- request comes for the resource path. If 'resGet' is Nothing,
72 -- the system responds \"405 Method Not Allowed\" for GET
75 -- It also runs for HEAD request if the 'resHead' is Nothing. In
76 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
77 -- don't actually write a response body.
78 , resGet :: !(Maybe (Resource ()))
79 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
80 -- request comes for the resource path. If 'resHead' is Nothing,
81 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
82 -- the system responds \"405 Method Not Allowed\" for HEAD
84 , resHead :: !(Maybe (Resource ()))
85 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
86 -- request comes for the resource path. If 'resPost' is Nothing,
87 -- the system responds \"405 Method Not Allowed\" for POST
89 , resPost :: !(Maybe (Resource ()))
90 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
91 -- request comes for the resource path. If 'resPut' is Nothing,
92 -- the system responds \"405 Method Not Allowed\" for PUT
94 , resPut :: !(Maybe (Resource ()))
95 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
96 -- DELETE request comes for the resource path. If 'resDelete' is
97 -- Nothing, the system responds \"405 Method Not Allowed\" for
99 , resDelete :: !(Maybe (Resource ()))
102 -- |'ResTree' is an opaque structure which is a map from resource path
104 newtype ResTree = ResTree ResNode -- root だから Map ではない
105 type ResSubtree = Map String ResNode
106 data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
108 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
111 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
112 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
115 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
116 mkResTree xs = xs `seq` processRoot xs
118 processRoot :: [ ([String], ResourceDef) ] -> ResTree
120 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
121 children = processNonRoot nonRoots
124 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
125 ResTree (ResNode Nothing children)
128 let (_, def) = last roots
130 ResTree (ResNode (Just def) children)
132 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
134 = let subtree = M.fromList [(name, node name)
135 | name <- childNames]
136 childNames = [name | (name:_, _) <- list]
137 node name = let defs = [def | (path, def) <- list, path == [name]]
142 ResNode Nothing children
145 ResNode (Just $ last defs) children
146 children = processNonRoot [(path, def)
147 | (_:path, def) <- list, not (null path)]
152 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
153 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
154 = do let pathStr = uriPath uri
155 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
156 foundInTree = if null path then
160 walkTree subtree path []
161 if isJust foundInTree then
166 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
169 = error "Internal error: should not reach here."
171 walkTree tree (name:[]) soFar
172 = case M.lookup name tree of
174 Just (ResNode defM _) -> do def <- defM
175 return (soFar ++ [name], def)
177 walkTree tree (x:xs) soFar
178 = case M.lookup x tree of
180 Just (ResNode defM children) -> case defM of
181 Just (ResourceDef { resIsGreedy = True })
183 return (soFar ++ [x], def)
184 _ -> walkTree children xs (soFar ++ [x])
186 fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
187 fallback _ [] = return Nothing
188 fallback path (x:xs) = do m <- x path
190 Just def -> return $! Just ([], def)
191 Nothing -> fallback path xs
194 runResource :: ResourceDef -> Interaction -> IO ThreadId
196 = def `seq` itr `seq`
198 $! catch ( runRes ( do req <- getRequest
199 fromMaybe notAllowed $ rsrc req
203 $ \ exc -> processException exc
205 fork :: IO () -> IO ThreadId
206 fork = if (resUsesNativeThread def)
210 rsrc :: Request -> Maybe (Resource ())
212 = case reqMethod req of
214 HEAD -> case resHead def of
216 Nothing -> resGet def
219 DELETE -> resDelete def
222 notAllowed :: Resource ()
223 notAllowed = do setStatus MethodNotAllowed
224 setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
226 allowedMethods :: [String]
227 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
228 , methods resHead ["GET", "HEAD"]
229 , methods resPost ["POST"]
230 , methods resPut ["PUT"]
231 , methods resDelete ["DELETE"]
234 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
235 methods f xs = case f def of
239 toAbortion :: SomeException -> Abortion
240 toAbortion e = case fromException e of
241 Just abortion -> abortion
242 Nothing -> Abortion InternalServerError emptyHeaders (Just (show e))
244 processException :: SomeException -> IO ()
246 = do let abo = toAbortion exc
248 -- まだ DecidingHeader 以前の状態だったら、この途中終了
249 -- を應答に反映させる餘地がある。さうでなければ stderr
251 state <- atomically $ readItr itr itrState id
252 reqM <- atomically $ readItr itr itrRequest id
253 res <- atomically $ readItr itr itrResponse id
254 if state <= DecidingHeader then
256 $ do setStatus $ aboStatus abo
257 mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
258 output $ abortPage conf reqM res abo
260 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
261 $ hPutStrLn stderr $ show abo
263 flip runRes itr $ driftTo Done
265 formatIOE :: IOError -> String
266 formatIOE ioE = if isUserError ioE then
267 ioeGetErrorString ioE