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
23 import qualified Data.Map as M
26 import Network.HTTP.Lucu.Abortion
27 import Network.HTTP.Lucu.Config
28 import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders)
29 import Network.HTTP.Lucu.Request
30 import Network.HTTP.Lucu.Resource
31 import Network.HTTP.Lucu.Response
32 import Network.HTTP.Lucu.Interaction
33 import Network.HTTP.Lucu.Utils
36 import System.IO.Error hiding (catch)
37 import Prelude hiding (catch)
40 -- |'FallbackHandler' is an extra resource handler for resources which
41 -- can't be statically located somewhere in the resource tree. The
42 -- Lucu httpd first search for a resource in the tree, and then call
43 -- fallback handlers to ask them for a resource. If all of the
44 -- handlers returned 'Prelude.Nothing', the httpd responds with 404
46 type FallbackHandler = [String] -> IO (Maybe ResourceDef)
49 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
50 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
51 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
54 -- | 'ResourceDef' is basically a set of
55 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
56 data ResourceDef = ResourceDef {
57 -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
58 -- native thread (spawned by 'Control.Concurrent.forkOS') or to
59 -- run it on a user thread (spanwed by
60 -- 'Control.Concurrent.forkIO'). Generally you don't need to set
61 -- this field to 'Prelude.True'.
62 resUsesNativeThread :: !Bool
63 -- | Whether to be greedy or not.
65 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
66 -- greedy resource at \/aaa\/bbb, it is always chosen even if
67 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
68 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
69 -- resources are like CGI scripts.
70 , resIsGreedy :: !Bool
71 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
72 -- request comes for the resource path. If 'resGet' is Nothing,
73 -- the system responds \"405 Method Not Allowed\" for GET
76 -- It also runs for HEAD request if the 'resHead' is Nothing. In
77 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
78 -- don't actually write a response body.
79 , resGet :: !(Maybe (Resource ()))
80 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
81 -- request comes for the resource path. If 'resHead' is Nothing,
82 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
83 -- the system responds \"405 Method Not Allowed\" for HEAD
85 , resHead :: !(Maybe (Resource ()))
86 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
87 -- request comes for the resource path. If 'resPost' is Nothing,
88 -- the system responds \"405 Method Not Allowed\" for POST
90 , resPost :: !(Maybe (Resource ()))
91 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
92 -- request comes for the resource path. If 'resPut' is Nothing,
93 -- the system responds \"405 Method Not Allowed\" for PUT
95 , resPut :: !(Maybe (Resource ()))
96 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
97 -- DELETE request comes for the resource path. If 'resDelete' is
98 -- Nothing, the system responds \"405 Method Not Allowed\" for
100 , resDelete :: !(Maybe (Resource ()))
103 -- |'ResTree' is an opaque structure which is a map from resource path
105 newtype ResTree = ResTree ResNode -- root だから Map ではない
106 type ResSubtree = Map String ResNode
107 data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
109 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
112 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
113 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
116 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
117 mkResTree list = list `seq` processRoot list
119 processRoot :: [ ([String], ResourceDef) ] -> ResTree
121 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
122 children = processNonRoot nonRoots
125 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
126 ResTree (ResNode Nothing children)
129 let (_, def) = last roots
131 ResTree (ResNode (Just def) children)
133 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
135 = let subtree = M.fromList [(name, node name)
136 | name <- childNames]
137 childNames = [name | (name:_, _) <- list]
138 node name = let defs = [def | (path, def) <- list, path == [name]]
143 ResNode Nothing children
146 ResNode (Just $ last defs) children
147 children = processNonRoot [(path, def)
148 | (_:path, def) <- list, not (null path)]
153 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
154 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
155 = do let pathStr = uriPath uri
156 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
157 foundInTree = if null path then
161 walkTree subtree path []
162 if isJust foundInTree then
167 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
169 walkTree subtree (name:[]) soFar
170 = case M.lookup name subtree of
172 Just (ResNode defM _) -> do def <- defM
173 return (soFar ++ [name], def)
175 walkTree subtree (x:xs) soFar
176 = case M.lookup x subtree of
178 Just (ResNode defM children) -> case defM of
179 Just (ResourceDef { resIsGreedy = True })
181 return (soFar ++ [x], def)
182 _ -> walkTree children xs (soFar ++ [x])
184 fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
185 fallback _ [] = return Nothing
186 fallback path (x:xs) = do m <- x path
188 Just def -> return $! Just ([], def)
189 Nothing -> fallback path xs
192 runResource :: ResourceDef -> Interaction -> IO ThreadId
194 = def `seq` itr `seq`
196 $! catch ( runRes ( do req <- getRequest
197 fromMaybe notAllowed $ rsrc req
201 $ \ exc -> processException exc
203 fork :: IO () -> IO ThreadId
204 fork = if (resUsesNativeThread def)
208 rsrc :: Request -> Maybe (Resource ())
210 = case reqMethod req of
212 HEAD -> case resHead def of
214 Nothing -> resGet def
217 DELETE -> resDelete def
219 notAllowed :: Resource ()
220 notAllowed = do setStatus MethodNotAllowed
221 setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
223 allowedMethods :: [String]
224 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
225 , methods resHead ["GET", "HEAD"]
226 , methods resPost ["POST"]
227 , methods resPut ["PUT"]
228 , methods resDelete ["DELETE"]
231 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
232 methods f xs = case f def of
236 processException :: Exception -> IO ()
238 = do let abo = case exc of
239 ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg
240 IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE
241 DynException dynE -> case fromDynamic dynE of
242 Just (abo :: Abortion) -> abo
244 -> Abortion InternalServerError emptyHeaders
246 _ -> Abortion InternalServerError emptyHeaders $ Just $ show 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