Many improvements: still in early development

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bc4bf3336389d959aa5bfedefcb857bf0e13b163..2e4d46e858f447fcec98601b1fc016e6f0272fd9 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,14 +1,109 @@
 module Network.HTTP.Lucu.Resource
-    ( Resource
+    ( ResourceDef(..)
+    , Resource
+    , ResTree
+    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
+    , findResource -- ResTree -> URI -> Maybe ResourceDef
+    , runResource  -- ResourceDef -> Interaction -> IO ThreadId
     )
     where
 
-import           Control.Monad.State
+import           Control.Concurrent
+import           Control.Monad.Reader
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
+import           Data.List
+import qualified Data.Map as M
+import           Data.Map (Map)
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Utils
+import           Network.URI
 
-data ResState = ResState -- FIXME
 
-type ResourceT m a = StateT ResState m a
+type Resource a = ReaderT Interaction IO a
 
-type Resource a = ResourceT IO a
+
+{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
+   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
+   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
+   される。 -}
+data ResourceDef = ResourceDef {
+      resUsesNativeThread :: Bool
+    , resIsGreedy         :: Bool
+    , resResource         :: Resource ()
+    }
+type ResTree    = ResNode -- root だから Map ではない
+type ResSubtree = Map String ResNode
+data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
+
+
+mkResTree :: [ ([String], ResourceDef) ] -> ResTree
+mkResTree list = processRoot list
+    where
+      processRoot :: [ ([String], ResourceDef) ] -> ResTree
+      processRoot list
+          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
+                children = processNonRoot nonRoots
+            in
+              if null roots then
+                  -- / にリソースが定義されない。/foo とかにはあるかも。
+                  ResNode Nothing children
+              else
+                  -- / がある。
+                  let (_, def) = last roots
+                  in 
+                    ResNode (Just def) children
+
+      processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
+      processNonRoot list
+          = let subtree    = M.fromList [(name, node name)
+                                             | name <- childNames]
+                childNames = [name | (name:_, _) <- list]
+                node name  = let defs = [def | (path, def) <- list, path == [name]]
+                             in
+                               if null defs then
+                                   -- この位置にリソースが定義されない。
+                                   -- もっと下にはあるかも。
+                                   ResNode Nothing children
+                               else
+                                   -- この位置にリソースがある。
+                                   ResNode (Just $ last defs) children
+                children   = processNonRoot [(path, def)
+                                                 | (_:path, def) <- list, not (null path)]
+            in
+              subtree
+
+
+findResource :: ResTree -> URI -> Maybe ResourceDef
+findResource (ResNode rootDefM subtree) uri
+    = let pathStr = uriPath uri
+          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
+      in
+        if null path then
+            rootDefM
+        else
+            walkTree subtree path
+    where
+      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+
+      walkTree subtree (name:[])
+          = case M.lookup name subtree of
+              Nothing               -> Nothing
+              Just (ResNode defM _) -> defM
+
+      walkTree subtree (x:xs)
+          = case M.lookup x subtree of
+              Nothing                      -> Nothing
+              Just (ResNode defM children) -> case defM of
+                                                Just (ResourceDef { resIsGreedy = True })
+                                                    -> defM
+                                                _   -> walkTree children xs
+
+
+runResource :: ResourceDef -> Interaction -> IO ThreadId
+runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+    where
+      fork = if (resUsesNativeThread def)
+             then forkOS
+             else forkIO
+      rsrc = resResource def
\ No newline at end of file