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.
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 = 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
171 $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
175 $ \ exc -> processException exc
177 fork :: IO () -> IO ThreadId
178 fork = if (resUsesNativeThread def)
182 rsrc :: Maybe (Resource ())
183 rsrc = case reqMethod $ fromJust $ itrRequest itr of
185 HEAD -> case resHead def of
187 Nothing -> resGet def
190 DELETE -> resDelete def
192 notAllowed :: Resource ()
193 notAllowed = do setStatus MethodNotAllowed
194 setHeader "Allow" $ joinWith ", " allowedMethods
196 allowedMethods :: [String]
197 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
198 , methods resHead ["GET", "HEAD"]
199 , methods resPost ["POST"]
200 , methods resPut ["PUT"]
201 , methods resDelete ["DELETE"]
204 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
205 methods f xs = case f def of
209 processException :: Exception -> IO ()
211 = do let abo = case exc of
212 ErrorCall msg -> Abortion InternalServerError [] $ Just msg
213 IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
214 DynException dynE -> case fromDynamic dynE of
215 Just (abo :: Abortion) -> abo
217 -> Abortion InternalServerError []
219 _ -> Abortion InternalServerError [] $ Just $ show exc
221 reqM = itrRequest itr
222 -- まだ DecidingHeader 以前の状態だったら、この途中終了
223 -- を應答に反映させる餘地がある。さうでなければ stderr
225 state <- atomically $ readItr itr itrState id
226 res <- atomically $ readItr itr itrResponse id
227 if state <= DecidingHeader then
229 $ do setStatus $ aboStatus abo
230 -- FIXME: 同じ名前で複數の値があった時は、こ
232 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
233 output $ abortPage conf reqM res abo
235 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
236 $ hPutStrLn stderr $ show abo
238 flip runReaderT itr $ driftTo Done
240 formatIOE :: IOError -> String
241 formatIOE ioE = if isUserError ioE then
242 ioeGetErrorString ioE