3 -- | Repository of the resources in httpd.
4 module Network.HTTP.Lucu.Resource.Tree
7 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
9 , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
10 , runResource -- ResourceDef -> Interaction -> IO ThreadId
14 import Control.Concurrent
15 import Control.Concurrent.STM
16 import Control.Exception
17 import Control.Monad.Reader
20 import qualified Data.Map as M
23 import Network.HTTP.Lucu.Abortion
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.MIMEType
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Resource
28 import Network.HTTP.Lucu.Response
29 import Network.HTTP.Lucu.Interaction
30 import Network.HTTP.Lucu.Utils
33 import System.IO.Error hiding (catch)
34 import Prelude hiding (catch)
37 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
38 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
39 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
42 -- | 'ResourceDef' is basically a set of
43 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
44 data ResourceDef = ResourceDef {
45 -- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
46 -- native thread (spawned using @forkOS@) or to run it on a user
47 -- thread (spanwed using @forkIO@). Generally you don't
48 resUsesNativeThread :: !Bool
49 -- | Whether to be greedy or not.
51 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
52 -- greedy resource at \/aaa\/bbb, it is always chosen even if
53 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
54 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
55 -- resource is like a CGI script.
56 , resIsGreedy :: !Bool
57 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
58 -- request comes for the resource path. If 'resGet' is Nothing,
59 -- the system responds \"405 Method Not Allowed\" for GET
62 -- It also runs for HEAD request if the 'resHead' is Nothing. In
63 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
64 -- don't actually write a response body.
65 , resGet :: !(Maybe (Resource ()))
66 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
67 -- request comes for the resource path. If 'resHead' is Nothing,
68 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
69 -- the system responds \"405 Method Not Allowed\" for HEAD
71 , resHead :: !(Maybe (Resource ()))
72 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
73 -- request comes for the resource path. If 'resPost' is Nothing,
74 -- the system responds \"405 Method Not Allowed\" for POST
76 , resPost :: !(Maybe (Resource ()))
77 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
78 -- request comes for the resource path. If 'resPut' is Nothing,
79 -- the system responds \"405 Method Not Allowed\" for PUT
81 , resPut :: !(Maybe (Resource ()))
82 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
83 -- DELETE request comes for the resource path. If 'resDelete' is
84 -- Nothing, the system responds \"405 Method Not Allowed\" for
86 , resDelete :: !(Maybe (Resource ()))
89 -- | 'ResTree' is an opaque structure which is a map from resource
90 -- path to 'ResourceDef'.
91 type ResTree = ResNode -- root だから Map ではない
92 type ResSubtree = Map String ResNode
93 data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
95 -- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
98 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
99 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
102 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
103 mkResTree list = list `seq` processRoot list
105 processRoot :: [ ([String], ResourceDef) ] -> ResTree
107 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
108 children = processNonRoot nonRoots
111 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
112 ResNode Nothing children
115 let (_, def) = last roots
117 ResNode (Just def) children
119 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
121 = let subtree = M.fromList [(name, node name)
122 | name <- childNames]
123 childNames = [name | (name:_, _) <- list]
124 node name = let defs = [def | (path, def) <- list, path == [name]]
129 ResNode Nothing children
132 ResNode (Just $ last defs) children
133 children = processNonRoot [(path, def)
134 | (_:path, def) <- list, not (null path)]
139 findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
140 findResource (ResNode rootDefM subtree) uri
141 = let pathStr = uriPath uri
142 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
148 walkTree subtree path []
150 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
152 walkTree subtree (name:[]) soFar
153 = case M.lookup name subtree of
155 Just (ResNode defM _) -> do def <- defM
156 return (soFar ++ [name], def)
158 walkTree subtree (x:xs) soFar
159 = case M.lookup x subtree of
161 Just (ResNode defM children) -> case defM of
162 Just (ResourceDef { resIsGreedy = True })
164 return (soFar ++ [x], def)
165 _ -> walkTree children xs (soFar ++ [x])
168 runResource :: ResourceDef -> Interaction -> IO ThreadId
170 = def `seq` itr `seq`
172 $! catch ( runReaderT ( do req <- getRequest
173 fromMaybe notAllowed $ rsrc req
177 $ \ exc -> processException exc
179 fork :: IO () -> IO ThreadId
180 fork = if (resUsesNativeThread def)
184 rsrc :: Request -> Maybe (Resource ())
186 = case reqMethod req of
188 HEAD -> case resHead def of
190 Nothing -> resGet def
193 DELETE -> resDelete def
195 notAllowed :: Resource ()
196 notAllowed = do setStatus MethodNotAllowed
197 setHeader "Allow" $ joinWith ", " allowedMethods
199 allowedMethods :: [String]
200 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
201 , methods resHead ["GET", "HEAD"]
202 , methods resPost ["POST"]
203 , methods resPut ["PUT"]
204 , methods resDelete ["DELETE"]
207 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
208 methods f xs = case f def of
212 processException :: Exception -> IO ()
214 = do let abo = case exc of
215 ErrorCall msg -> Abortion InternalServerError [] $ Just msg
216 IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
217 DynException dynE -> case fromDynamic dynE of
218 Just (abo :: Abortion) -> abo
220 -> Abortion InternalServerError []
222 _ -> Abortion InternalServerError [] $ Just $ show exc
224 -- まだ DecidingHeader 以前の状態だったら、この途中終了
225 -- を應答に反映させる餘地がある。さうでなければ stderr
227 state <- atomically $ readItr itr itrState id
228 reqM <- atomically $ readItr itr itrRequest id
229 res <- atomically $ readItr itr itrResponse id
230 if state <= DecidingHeader then
232 $ do setStatus $ aboStatus abo
233 -- FIXME: 同じ名前で複數の値があった時は、こ
235 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
236 output $ abortPage conf reqM res abo
238 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
239 $ hPutStrLn stderr $ show abo
241 flip runReaderT itr $ driftTo Done
243 formatIOE :: IOError -> String
244 formatIOE ioE = if isUserError ioE then
245 ioeGetErrorString ioE