Changes from 0.4 to 0.4.1

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

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 06fed17dd13c7d52af6d49e7f65ca3adcc164fb8..660d8ff735bdc3f2fab18f7d42ab8a1f8951a091 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -3,6 +3,8 @@
 -- | Repository of the resources in httpd.
 module Network.HTTP.Lucu.Resource.Tree
     ( ResourceDef(..)
+    , emptyResource
+
     , ResTree
     , FallbackHandler
 
@@ -98,11 +100,37 @@ data ResourceDef = ResourceDef {
     , resDelete           :: !(Maybe (Resource ()))
     }
 
+-- |'emptyResource' is a resource definition with no actual
+-- handlers. You can construct a 'ResourceDef' by selectively
+-- overriding 'emptyResource'. It is defined as follows:
+--
+-- @
+--   emptyResource = ResourceDef {
+--                     resUsesNativeThread = False
+--                   , resIsGreedy         = False
+--                   , resGet              = Nothing
+--                   , resHead             = Nothing
+--                   , resPost             = Nothing
+--                   , resPut              = Nothing
+--                   , resDelete           = Nothing
+--                   }
+-- @
+emptyResource :: ResourceDef
+emptyResource = ResourceDef {
+                  resUsesNativeThread = False
+                , resIsGreedy         = False
+                , resGet              = Nothing
+                , resHead             = Nothing
+                , resPost             = Nothing
+                , resPut              = Nothing
+                , resDelete           = Nothing
+                }
+
 -- |'ResTree' is an opaque structure which is a map from resource path
 -- to 'ResourceDef'.
 newtype ResTree = ResTree ResNode -- root だから Map ではない
 type ResSubtree = Map String ResNode
-data ResNode    = ResNode !(Maybe ResourceDef) !ResSubtree
+data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
 
 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 --
@@ -112,18 +140,25 @@ data ResNode    = ResNode !(Maybe ResourceDef) !ResSubtree
 --             ]
 -- @
 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
-mkResTree xs = xs `seq` processRoot xs
+mkResTree = processRoot . mapFirst canonicalisePath
     where
+      mapFirst :: (a -> a') -> [(a, b)] -> [(a', b)]
+      mapFirst f = map (\ (a, b) -> (f a, b))
+
+      canonicalisePath :: [String] -> [String]
+      canonicalisePath = filter (\ x -> x /= "")
+
       processRoot :: [ ([String], ResourceDef) ] -> ResTree
       processRoot list
           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
                 children = processNonRoot nonRoots
             in
               if null roots then
-                  -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
+                  -- The root has no resources. Maybe there's one at
+                  -- somewhere like "/foo".
                   ResTree (ResNode Nothing children)
               else
-                  -- "/" がある。
+                  -- There is a root resource.
                   let (_, def) = last roots
                   in 
                     ResTree (ResNode (Just def) children)
@@ -136,27 +171,31 @@ mkResTree xs = xs `seq` processRoot xs
                 node name  = let defs = [def | (path, def) <- list, path == [name]]
                              in
                                if null defs then
-                                   -- この位置にリソースが定義されない。
-                                   -- もっと下にはあるかも。
+                                   -- No resources are defined
+                                   -- here. Maybe there's one at
+                                   -- somewhere below this node.
                                    ResNode Nothing children
                                else
-                                   -- この位置にリソースがある。
+                                   -- There is a resource here.
                                    ResNode (Just $ last defs) children
                 children   = processNonRoot [(path, def)
-                                                 | (_:path, def) <- list, not (null path)]
+                                                 | (_:path, def) <- list]
             in
               subtree
 
 
 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
-    = do let pathStr     = uriPath uri
-             path        = [x | x <- splitBy (== '/') pathStr, x /= ""]
-             foundInTree = if null path then
-                               do def <- rootDefM
-                                  return (path, def)
-                           else
-                               walkTree subtree path []
+    = do let pathStr        = uriPath uri
+             path           = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""]
+             haveGreedyRoot = case rootDefM of
+                                Just def -> resIsGreedy def
+                                Nothing  -> False
+             foundInTree    = if haveGreedyRoot || null path then
+                                  do def <- rootDefM
+                                     return ([], def)
+                              else
+                                  walkTree subtree path []
          if isJust foundInTree then
              return foundInTree
            else