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.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 using @forkOS@) or to run it on a user
46 -- thread (spanwed using @forkIO@). Generally you don't
47 resUsesNativeThread :: !Bool
48 -- | Whether to be greedy or not.
50 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
51 -- greedy resource at \/aaa\/bbb, it is always chosen even if
52 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
53 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
54 -- resource is like a CGI script.
55 , resIsGreedy :: !Bool
56 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
57 -- request comes for the resource path. If 'resGet' is Nothing,
58 -- the system responds \"405 Method Not Allowed\" for GET
61 -- It also runs for HEAD request if the 'resHead' is Nothing. In
62 -- this case 'Network.HTTP.Lucu.Resource.output' and such like
63 -- don't actually write a response body.
64 , resGet :: !(Maybe (Resource ()))
65 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
66 -- request comes for the resource path. If 'resHead' is Nothing,
67 -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
68 -- the system responds \"405 Method Not Allowed\" for HEAD
70 , resHead :: !(Maybe (Resource ()))
71 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
72 -- request comes for the resource path. If 'resPost' is Nothing,
73 -- the system responds \"405 Method Not Allowed\" for POST
75 , resPost :: !(Maybe (Resource ()))
76 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
77 -- request comes for the resource path. If 'resPut' is Nothing,
78 -- the system responds \"405 Method Not Allowed\" for PUT
80 , resPut :: !(Maybe (Resource ()))
81 -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
82 -- DELETE request comes for the resource path. If 'resDelete' is
83 -- Nothing, the system responds \"405 Method Not Allowed\" for
85 , resDelete :: !(Maybe (Resource ()))
88 -- | 'ResTree' is an opaque structure which is a map from resource
89 -- path to 'ResourceDef'.
90 type ResTree = ResNode -- root だから Map ではない
91 type ResSubtree = Map String ResNode
92 data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
94 -- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
97 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
98 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
101 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
102 mkResTree list = list `seq` processRoot list
104 processRoot :: [ ([String], ResourceDef) ] -> ResTree
106 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
107 children = processNonRoot nonRoots
110 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
111 ResNode Nothing children
114 let (_, def) = last roots
116 ResNode (Just def) children
118 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
120 = let subtree = M.fromList [(name, node name)
121 | name <- childNames]
122 childNames = [name | (name:_, _) <- list]
123 node name = let defs = [def | (path, def) <- list, path == [name]]
128 ResNode Nothing children
131 ResNode (Just $ last defs) children
132 children = processNonRoot [(path, def)
133 | (_:path, def) <- list, not (null path)]
138 findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
139 findResource (ResNode rootDefM subtree) uri
140 = let pathStr = uriPath uri
141 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
147 walkTree subtree path []
149 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
151 walkTree subtree (name:[]) soFar
152 = case M.lookup name subtree of
154 Just (ResNode defM _) -> do def <- defM
155 return (soFar ++ [name], def)
157 walkTree subtree (x:xs) soFar
158 = case M.lookup x subtree of
160 Just (ResNode defM children) -> case defM of
161 Just (ResourceDef { resIsGreedy = True })
163 return (soFar ++ [x], def)
164 _ -> walkTree children xs (soFar ++ [x])
167 runResource :: ResourceDef -> Interaction -> IO ThreadId
169 = def `seq` itr `seq`
171 $! catch ( runReaderT ( do req <- getRequest
172 fromMaybe notAllowed $ rsrc req
176 $ \ exc -> processException exc
178 fork :: IO () -> IO ThreadId
179 fork = if (resUsesNativeThread def)
183 rsrc :: Request -> Maybe (Resource ())
185 = case reqMethod req of
187 HEAD -> case resHead def of
189 Nothing -> resGet def
192 DELETE -> resDelete def
194 notAllowed :: Resource ()
195 notAllowed = do setStatus MethodNotAllowed
196 setHeader "Allow" $ joinWith ", " allowedMethods
198 allowedMethods :: [String]
199 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
200 , methods resHead ["GET", "HEAD"]
201 , methods resPost ["POST"]
202 , methods resPut ["PUT"]
203 , methods resDelete ["DELETE"]
206 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
207 methods f xs = case f def of
211 processException :: Exception -> IO ()
213 = do let abo = case exc of
214 ErrorCall msg -> Abortion InternalServerError [] $ Just msg
215 IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
216 DynException dynE -> case fromDynamic dynE of
217 Just (abo :: Abortion) -> abo
219 -> Abortion InternalServerError []
221 _ -> Abortion InternalServerError [] $ Just $ show exc
223 -- まだ DecidingHeader 以前の状態だったら、この途中終了
224 -- を應答に反映させる餘地がある。さうでなければ stderr
226 state <- atomically $ readItr itr itrState id
227 reqM <- atomically $ readItr itr itrRequest id
228 res <- atomically $ readItr itr itrResponse id
229 if state <= DecidingHeader then
231 $ do setStatus $ aboStatus abo
232 -- FIXME: 同じ名前で複數の値があった時は、こ
234 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
235 output $ abortPage conf reqM res abo
237 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
238 $ hPutStrLn stderr $ show abo
240 flip runReaderT itr $ driftTo Done
242 formatIOE :: IOError -> String
243 formatIOE ioE = if isUserError ioE then
244 ioeGetErrorString ioE