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
20 import qualified Data.Map as M
23 import Network.HTTP.Lucu.Abortion
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Resource
27 import Network.HTTP.Lucu.Response
28 import Network.HTTP.Lucu.Interaction
29 import Network.HTTP.Lucu.Utils
32 import System.IO.Error hiding (catch)
33 import Prelude hiding (catch)
36 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
37 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
38 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
41 -- | 'ResourceDef' is basically a set of
42 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
43 data ResourceDef = ResourceDef {
44 -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
45 -- native thread (spawned by 'Control.Concurrent.forkOS') or to
46 -- run it on a user thread (spanwed by
47 -- 'Control.Concurrent.forkIO'). Generally you don't need to set
48 -- this field to 'Prelude.True'.
49 resUsesNativeThread :: !Bool
50 -- | Whether to be greedy or not.
52 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
53 -- greedy resource at \/aaa\/bbb, it is always chosen even if
54 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
55 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
56 -- resource is like a CGI script.
57 , resIsGreedy :: !Bool
58 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
59 -- request comes for the resource path. If 'resGet' is Nothing,
60 -- the system responds \"405 Method Not Allowed\" for GET
63 -- It also runs for HEAD request if the 'resHead' is Nothing. In
64 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
65 -- don't actually write a response body.
66 , resGet :: !(Maybe (Resource ()))
67 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
68 -- request comes for the resource path. If 'resHead' is Nothing,
69 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
70 -- the system responds \"405 Method Not Allowed\" for HEAD
72 , resHead :: !(Maybe (Resource ()))
73 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
74 -- request comes for the resource path. If 'resPost' is Nothing,
75 -- the system responds \"405 Method Not Allowed\" for POST
77 , resPost :: !(Maybe (Resource ()))
78 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
79 -- request comes for the resource path. If 'resPut' is Nothing,
80 -- the system responds \"405 Method Not Allowed\" for PUT
82 , resPut :: !(Maybe (Resource ()))
83 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
84 -- DELETE request comes for the resource path. If 'resDelete' is
85 -- Nothing, the system responds \"405 Method Not Allowed\" for
87 , resDelete :: !(Maybe (Resource ()))
90 -- | 'ResTree' is an opaque structure which is a map from resource
91 -- path to 'ResourceDef'.
92 type ResTree = ResNode -- root だから Map ではない
93 type ResSubtree = Map String ResNode
94 data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
96 -- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
99 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
100 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
103 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
104 mkResTree list = list `seq` processRoot list
106 processRoot :: [ ([String], ResourceDef) ] -> ResTree
108 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
109 children = processNonRoot nonRoots
112 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
113 ResNode Nothing children
116 let (_, def) = last roots
118 ResNode (Just def) children
120 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
122 = let subtree = M.fromList [(name, node name)
123 | name <- childNames]
124 childNames = [name | (name:_, _) <- list]
125 node name = let defs = [def | (path, def) <- list, path == [name]]
130 ResNode Nothing children
133 ResNode (Just $ last defs) children
134 children = processNonRoot [(path, def)
135 | (_:path, def) <- list, not (null path)]
140 findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
141 findResource (ResNode rootDefM subtree) uri
142 = let pathStr = uriPath uri
143 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
149 walkTree subtree path []
151 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
153 walkTree subtree (name:[]) soFar
154 = case M.lookup name subtree of
156 Just (ResNode defM _) -> do def <- defM
157 return (soFar ++ [name], def)
159 walkTree subtree (x:xs) soFar
160 = case M.lookup x subtree of
162 Just (ResNode defM children) -> case defM of
163 Just (ResourceDef { resIsGreedy = True })
165 return (soFar ++ [x], def)
166 _ -> walkTree children xs (soFar ++ [x])
169 runResource :: ResourceDef -> Interaction -> IO ThreadId
171 = def `seq` itr `seq`
173 $! catch ( runRes ( do req <- getRequest
174 fromMaybe notAllowed $ rsrc req
178 $ \ exc -> processException exc
180 fork :: IO () -> IO ThreadId
181 fork = if (resUsesNativeThread def)
185 rsrc :: Request -> Maybe (Resource ())
187 = case reqMethod req of
189 HEAD -> case resHead def of
191 Nothing -> resGet def
194 DELETE -> resDelete def
196 notAllowed :: Resource ()
197 notAllowed = do setStatus MethodNotAllowed
198 setHeader "Allow" $ joinWith ", " allowedMethods
200 allowedMethods :: [String]
201 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
202 , methods resHead ["GET", "HEAD"]
203 , methods resPost ["POST"]
204 , methods resPut ["PUT"]
205 , methods resDelete ["DELETE"]
208 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
209 methods f xs = case f def of
213 processException :: Exception -> IO ()
215 = do let abo = case exc of
216 ErrorCall msg -> Abortion InternalServerError [] $ Just msg
217 IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
218 DynException dynE -> case fromDynamic dynE of
219 Just (abo :: Abortion) -> abo
221 -> Abortion InternalServerError []
223 _ -> Abortion InternalServerError [] $ Just $ show exc
225 -- まだ DecidingHeader 以前の状態だったら、この途中終了
226 -- を應答に反映させる餘地がある。さうでなければ stderr
228 state <- atomically $ readItr itr itrState id
229 reqM <- atomically $ readItr itr itrRequest id
230 res <- atomically $ readItr itr itrResponse id
231 if state <= DecidingHeader then
233 $ do setStatus $ aboStatus abo
234 -- FIXME: 同じ名前で複數の値があった時は、こ
236 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
237 output $ abortPage conf reqM res abo
239 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
240 $ hPutStrLn stderr $ show abo
242 flip runRes itr $ driftTo Done
244 formatIOE :: IOError -> String
245 formatIOE ioE = if isUserError ioE then
246 ioeGetErrorString ioE