X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=72589200892f3f230cdf644082da384cd16a6dae;hb=57b93dc50655857941cc176aed2fc085e6555ff7;hp=f86eb1f4dacecf75bc5ef663e217b7828d208481;hpb=761b90ab4f413d2e83460f170082f3b15bbaef4f;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index f86eb1f..7258920 100644
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -1,24 +1,23 @@
 {-# LANGUAGE
-    DoAndIfThenElse
-  , ExistentialQuantification
+    ExistentialQuantification
+  , FlexibleContexts
   , FlexibleInstances
   , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
-  , RecordWildCards
-  , ScopedTypeVariables
   , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Dispatcher.Internal
-    ( SchemeMapper(..)
-    , SchemeMap
-    , HostMapper(..)
+    ( HostMapper(..)
     , HostMap
     , ResourceMapper(..)
     , ResourceMap
     , ResourceTree
+    , ResourceNode
+    , greedy
+    , nonGreedy
 
     , dispatch
     )
@@ -27,28 +26,15 @@ import Control.Applicative hiding (empty)
 import Control.Monad.Trans.Maybe
 import Control.Monad.Unicode
 import Data.Collections
-import qualified Data.Collections.Newtype.TH as C
+import qualified Data.Map as M
 import Data.Monoid
 import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Dispatcher.Node
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.URI hiding (path)
-import Prelude hiding (lookup)
+import Prelude hiding (filter, lookup, null)
 import Prelude.Unicode
 
--- |FIXME: docs
---
--- Minimal complete definition: 'findHostMap'
-class SchemeMapper α where
-    findHostMap ∷ Scheme → α → MaybeT IO HostMap
-    schemeMap   ∷ α → SchemeMap
-    {-# INLINE schemeMap #-}
-    schemeMap   = SMap
-
--- |Container type for the 'SchemeMapper' type class.
-data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
-
 -- |FIXME: docs
 --
 -- Minimal complete definition: 'findResourceMap'
@@ -65,7 +51,7 @@ data HostMap = ∀α. HostMapper α ⇒ HMap α
 --
 -- Minimal complete definition: 'findResource'
 class ResourceMapper α where
-    findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
+    findResource ∷ Path → α → MaybeT IO (Path, Resource)
     resourceMap  ∷ α → ResourceMap
     {-# INLINE resourceMap #-}
     resourceMap = RMap
@@ -73,70 +59,37 @@ class ResourceMapper α where
 -- |Container type for the 'ResourceMapper' type class.
 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
--- FIXME: doc
-newtype ResourceTree = Root ResourceNode
-    deriving (Monoid, Show)
-
--- Instances of SchemeMapper --------------------------------------------------
-instance SchemeMapper SchemeMap where
-    {-# INLINE findHostMap #-}
-    findHostMap s (SMap α) = findHostMap s α
-    {-# INLINE schemeMap #-}
-    schemeMap = id
-
--- |'HostMap's are also 'SchemeMapper's too, which matches to any
--- schemes.
-instance SchemeMapper HostMap where
-    {-# INLINE findHostMap #-}
-    findHostMap = const return
-
--- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
--- schemes and hosts.
-instance SchemeMapper ResourceMap where
-    {-# INLINE findHostMap #-}
-    findHostMap _ r = return $ hostMap f
-        where
-          f ∷ Host → Maybe ResourceMap
-          {-# INLINE f #-}
-          f = const $ Just r
-
--- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
-instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
-    {-# INLINE insert #-}
-    insert a (SMap b) = schemeMap c
-        where
-          c ∷ Scheme → MaybeT IO HostMap
-          {-# INLINEABLE c #-}
-          c s = findHostMap s a <|> findHostMap s b
-    {-# INLINE empty #-}
-    empty = (∅)
-    {-# INLINE singleton #-}
-    singleton = schemeMap
-
--- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
-instance Monoid SchemeMap where
-    {-# INLINE mempty #-}
-    mempty = schemeMap e
-        where
-          e ∷ Scheme → MaybeT IO HostMap
-          {-# INLINE e #-}
-          e = const (fail (⊥))
-    {-# INLINE mappend #-}
-    mappend = insert
+-- |'ResourceTree' is an opaque structure which is a map from resource
+-- path to 'Resource'.
+--
+-- @
+--   'fromList' [ ([]        , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
+--            , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
+--            ]
+-- @
+--
+-- Note that path segments are always represented as octet streams in
+-- this system. Lucu automatically decodes percent-encoded URIs but
+-- has no involvement in character encodings such as UTF-8, since RFC
+-- 2616 (HTTP/1.1) says nothing about character encodings to be used
+-- in \"http\" and \"https\" URI schemas.
+newtype ResourceTree = Tree (M.Map Path ResourceNode)
+    deriving Monoid
 
-instance Map α Scheme HostMap ⇒ SchemeMapper α where
-    {-# INLINE findHostMap #-}
-    findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
+-- |FIXME: doc
+data ResourceNode
+    = Greedy    { nResource ∷ !Resource }
+    | NonGreedy { nResource ∷ !Resource }
 
--- |An IO-based scheme mapper.
-instance SchemeMapper (Scheme → MaybeT IO HostMap) where
-    {-# INLINE findHostMap #-}
-    findHostMap = flip id
+-- |FIXME: doc
+greedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE greedy #-}
+greedy = Greedy
 
--- |A pure scheme mapper.
-instance SchemeMapper (Scheme → Maybe HostMap) where
-    {-# INLINE findHostMap #-}
-    findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
+-- |FIXME: doc
+nonGreedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE nonGreedy #-}
+nonGreedy = NonGreedy
 
 
 -- Instances of HostMapper ----------------------------------------------------
@@ -176,6 +129,7 @@ instance Monoid HostMap where
     {-# INLINE mappend #-}
     mappend = insert
 
+-- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
 instance Map α Host ResourceMap ⇒ HostMapper α where
     {-# INLINE findResourceMap #-}
     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
@@ -202,7 +156,7 @@ instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
     {-# INLINE insert #-}
     insert a (RMap b) = resourceMap c
         where
-          c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+          c ∷ Path → MaybeT IO (Path, Resource)
           {-# INLINEABLE c #-}
           c s = findResource s a <|> findResource s b
     {-# INLINE empty #-}
@@ -215,95 +169,64 @@ instance Monoid ResourceMap where
     {-# INLINE mempty #-}
     mempty = resourceMap e
         where
-          e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+          e ∷ Path → MaybeT IO (Path, Resource)
           {-# INLINE e #-}
           e = const (fail (⊥))
     {-# INLINE mappend #-}
     mappend = insert
 
-instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
+-- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
+-- 'ResourceMapper's.
+instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
     {-# INLINE findResource #-}
     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 
 -- |An IO-based resource mapper.
-instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
+instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
     {-# INLINE findResource #-}
     findResource = flip id
 
 -- |A pure resource mapper.
-instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
+instance ResourceMapper (Path → Maybe (Path, Resource)) where
     {-# INLINE findResource #-}
     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 
 -- Instances of ResourceTree --------------------------------------------------
-C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
-           |]
+instance Unfoldable ResourceTree (Path, ResourceNode) where
+    {-# INLINEABLE insert #-}
+    insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
+    {-# INLINE empty #-}
+    empty = Tree (∅)
+    {-# INLINE singleton #-}
+    singleton = Tree ∘ singleton
+
+canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
+{-# INLINEABLE canonPath #-}
+canonPath = filter ((¬) ∘ null)
+
+-- |'findResource' performs the longest prefix match on the tree,
+-- finding the most specific one.
+instance ResourceMapper ResourceTree where
+    {-# INLINEABLE findResource #-}
+    findResource p (Tree m)
+        = case lookup p m of
+            Just n  → return (p, nResource n)
+            Nothing → findGreedyResource p m
+
+findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
+                   ⇒ Path
+                   → α
+                   → MaybeT m (Path, Resource)
+findGreedyResource p m
+    = case back p of
+        Nothing      → fail (⊥)
+        Just (p', _) → case lookup p' m of
+                          Just (Greedy r)
+                              → return (p', r)
+                          _   → findGreedyResource p' m
 
 -- dispatch -------------------------------------------------------------------
-dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
+dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
 dispatch uri
     = (findResource (uriPathSegments uri) =≪)
-      ∘ (findResourceMap (uriHost uri) =≪)
-      ∘ findHostMap (uriCIScheme uri)
-
-{-
--- |'ResTree' is an opaque structure which is a map from resource path
--- to 'Resource'.
-newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map ByteString ResNode
-data ResNode    = ResNode (Maybe Resource) ResSubtree
-
--- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
---
--- @
---   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
---             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
---             ]
--- @
---
--- Note that path components are always represented as octet streams
--- in this system. Lucu automatically decodes percent-encoded URIs but
--- has no involvement in character encodings such as UTF-8, since RFC
--- 2616 (HTTP/1.1) says nothing about character encodings to be used
--- in \"http\" and \"https\" URI schemas.
-mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
-mkResTree = processRoot ∘ map (first canonicalisePath)
-    where
-      canonicalisePath ∷ [ByteString] → [ByteString]
-      canonicalisePath = filter ((¬) ∘ BS.null)
-
-      processRoot ∷ [ ([ByteString], Resource) ] → ResTree
-      processRoot list
-          = let (roots, nonRoots) = partition (\(path, _) → null path) list
-                children = processNonRoot nonRoots
-            in
-              if null roots then
-                  -- 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)
-
-      processNonRoot ∷ [ ([ByteString], Resource) ] → 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
-                                   -- 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]
-            in
-              subtree
--}
\ No newline at end of file
+      ∘ findResourceMap (uriHost uri)