1 module Network.HTTP.Lucu.Resource.Tree
4 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
6 , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
7 , runResource -- ResourceDef -> Interaction -> IO ThreadId
11 import Control.Concurrent
12 import Control.Concurrent.STM
13 import Control.Exception
14 import Control.Monad.Reader
17 import qualified Data.Map as M
20 import Network.HTTP.Lucu.Abortion
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.MIMEType
23 import Network.HTTP.Lucu.Request
24 import Network.HTTP.Lucu.Resource
25 import Network.HTTP.Lucu.Response
26 import Network.HTTP.Lucu.Interaction
27 import Network.HTTP.Lucu.Utils
30 import System.IO.Error hiding (catch)
31 import Prelude hiding (catch)
34 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
35 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
36 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
38 data ResourceDef = ResourceDef {
39 resUsesNativeThread :: Bool
41 , resGet :: Maybe (Resource ())
42 , resHead :: Maybe (Resource ())
43 , resPost :: Maybe (Resource ())
44 , resPut :: Maybe (Resource ())
45 , resDelete :: Maybe (Resource ())
47 type ResTree = ResNode -- root だから Map ではない
48 type ResSubtree = Map String ResNode
49 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
52 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
53 mkResTree list = processRoot list
55 processRoot :: [ ([String], ResourceDef) ] -> ResTree
57 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
58 children = processNonRoot nonRoots
61 -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
62 ResNode Nothing children
65 let (_, def) = last roots
67 ResNode (Just def) children
69 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
71 = let subtree = M.fromList [(name, node name)
73 childNames = [name | (name:_, _) <- list]
74 node name = let defs = [def | (path, def) <- list, path == [name]]
79 ResNode Nothing children
82 ResNode (Just $ last defs) children
83 children = processNonRoot [(path, def)
84 | (_:path, def) <- list, not (null path)]
89 findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
90 findResource (ResNode rootDefM subtree) uri
91 = let pathStr = uriPath uri
92 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
98 walkTree subtree path []
100 walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
102 walkTree subtree (name:[]) soFar
103 = case M.lookup name subtree of
105 Just (ResNode defM _) -> do def <- defM
106 return (soFar ++ [name], def)
108 walkTree subtree (x:xs) soFar
109 = case M.lookup x subtree of
111 Just (ResNode defM children) -> case defM of
112 Just (ResourceDef { resIsGreedy = True })
114 return (soFar ++ [x], def)
115 _ -> walkTree children xs (soFar ++ [x])
118 runResource :: ResourceDef -> Interaction -> IO ThreadId
121 $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
125 $ \ exc -> processException exc
127 fork :: IO () -> IO ThreadId
128 fork = if (resUsesNativeThread def)
132 rsrc :: Maybe (Resource ())
133 rsrc = case reqMethod $ fromJust $ itrRequest itr of
135 HEAD -> case resHead def of
137 Nothing -> resGet def
140 DELETE -> resDelete def
142 notAllowed :: Resource ()
143 notAllowed = do setStatus MethodNotAllowed
144 setHeader "Allow" $ joinWith ", " allowedMethods
146 allowedMethods :: [String]
147 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
148 , methods resHead ["GET", "HEAD"]
149 , methods resPost ["POST"]
150 , methods resPut ["PUT"]
151 , methods resDelete ["DELETE"]
154 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
155 methods f xs = case f def of
159 processException :: Exception -> IO ()
161 = do let abo = case exc of
162 ErrorCall msg -> Abortion InternalServerError [] $ Just msg
163 IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
164 DynException dynE -> case fromDynamic dynE of
165 Just (abo :: Abortion) -> abo
167 -> Abortion InternalServerError []
169 _ -> Abortion InternalServerError [] $ Just $ show exc
171 reqM = itrRequest itr
172 -- まだ DecidingHeader 以前の状態だったら、この途中終了
173 -- を應答に反映させる餘地がある。さうでなければ stderr
175 state <- atomically $ readItr itr itrState id
176 resM <- atomically $ readItr itr itrResponse id
177 if state <= DecidingHeader then
179 $ do setStatus $ aboStatus abo
180 -- FIXME: 同じ名前で複數の値があった時は、こ
182 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
183 setContentType ("application" </> "xhtml+xml")
184 output $ abortPage conf reqM resM abo
186 hPutStrLn stderr $ show abo
188 flip runReaderT itr $ driftTo Done
190 formatIOE :: IOError -> String
191 formatIOE ioE = if isUserError ioE then
192 ioeGetErrorString ioE