1 module Network.HTTP.Lucu.Resource
5 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
6 , findResource -- ResTree -> URI -> Maybe ResourceDef
7 , runResource -- ResourceDef -> Interaction -> IO ThreadId
11 import Control.Concurrent
12 import Control.Monad.Reader
13 import qualified Data.ByteString.Lazy.Char8 as B
14 import Data.ByteString.Lazy.Char8 (ByteString)
16 import qualified Data.Map as M
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.Utils
23 type Resource a = ReaderT Interaction IO a
26 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
27 れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
28 /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
30 data ResourceDef = ResourceDef {
31 resUsesNativeThread :: Bool
33 , resResource :: Resource ()
35 type ResTree = ResNode -- root だから Map ではない
36 type ResSubtree = Map String ResNode
37 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
40 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
41 mkResTree list = processRoot list
43 processRoot :: [ ([String], ResourceDef) ] -> ResTree
45 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
46 children = processNonRoot nonRoots
49 -- / にリソースが定義されない。/foo とかにはあるかも。
50 ResNode Nothing children
53 let (_, def) = last roots
55 ResNode (Just def) children
57 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
59 = let subtree = M.fromList [(name, node name)
61 childNames = [name | (name:_, _) <- list]
62 node name = let defs = [def | (path, def) <- list, path == [name]]
67 ResNode Nothing children
70 ResNode (Just $ last defs) children
71 children = processNonRoot [(path, def)
72 | (_:path, def) <- list, not (null path)]
77 findResource :: ResTree -> URI -> Maybe ResourceDef
78 findResource (ResNode rootDefM subtree) uri
79 = let pathStr = uriPath uri
80 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
87 walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
89 walkTree subtree (name:[])
90 = case M.lookup name subtree of
92 Just (ResNode defM _) -> defM
94 walkTree subtree (x:xs)
95 = case M.lookup x subtree of
97 Just (ResNode defM children) -> case defM of
98 Just (ResourceDef { resIsGreedy = True })
100 _ -> walkTree children xs
103 runResource :: ResourceDef -> Interaction -> IO ThreadId
104 runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
106 fork = if (resUsesNativeThread def)
109 rsrc = resResource def