Resource paths should not be assumed to be encoded in UTF-8. HTTP/1.1 says nothing...

[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 9ab6f663254f9cf8c5e28e183ba2ccaddf7cdd25..f3fca16b50520ff154775e1bcc3db58918a09ba9 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -15,28 +15,18 @@ module Network.HTTP.Lucu.Resource.Tree
     )
     where
 import Control.Arrow
-import Control.Applicative
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
 import Control.Monad
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Foldable
 import Data.List
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Maybe
 import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.Headers (fromHeaders)
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Interaction
+import Data.Sequence (Seq)
+import Data.Sequence.Unicode hiding ((∅))
+import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.URI hiding (path)
 import System.IO
@@ -48,12 +38,12 @@ import Prelude.Unicode
 -- httpd first searches for a resource in the tree, and then calls
 -- fallback handlers to ask them for a resource. If all of the
 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
-type FallbackHandler = [Text] → IO (Maybe ResourceDef)
+type FallbackHandler = [ByteString] → IO (Maybe ResourceDef)
 
 -- |'ResTree' is an opaque structure which is a map from resource path
 -- to 'ResourceDef'.
 newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map Text ResNode
+type ResSubtree = Map ByteString ResNode
 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
 
 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
@@ -64,15 +54,18 @@ data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
 --             ]
 -- @
 --
--- Note that the request path in an incoming HTTP request is always
--- treated as an URI-encoded UTF-8 string.
-mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
+-- 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], ResourceDef) ] → ResTree
 mkResTree = processRoot ∘ map (first canonicalisePath)
     where
-      canonicalisePath ∷ [Text] → [Text]
-      canonicalisePath = filter (≢ "")
+      canonicalisePath ∷ [ByteString] → [ByteString]
+      canonicalisePath = filter ((¬) ∘ BS.null)
 
-      processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
+      processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree
       processRoot list
           = let (roots, nonRoots) = partition (\(path, _) → null path) list
                 children = processNonRoot nonRoots
@@ -87,7 +80,7 @@ mkResTree = processRoot ∘ map (first canonicalisePath)
                   in 
                     ResTree (ResNode (Just def) children)
 
-      processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
+      processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
       processNonRoot list
           = let subtree    = M.fromList [(name, node name)
                                              | name ← childNames]
@@ -107,7 +100,10 @@ mkResTree = processRoot ∘ map (first canonicalisePath)
             in
               subtree
 
-findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
+findResource ∷ ResTree
+             → [FallbackHandler]
+             → URI
+             → IO (Maybe ([ByteString], ResourceDef))
 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
     = do let path          = splitPathInfo uri
              hasGreedyRoot = maybe False resIsGreedy rootDefM
@@ -115,13 +111,16 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri
                                   do def ← rootDefM
                                      return ([], def)
                               else
-                                  walkTree subtree path []
+                                  walkTree subtree path (∅)
          if isJust foundInTree then
              return foundInTree
          else
              fallback path fbs
     where
-      walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
+      walkTree ∷ ResSubtree
+               → [ByteString]
+               → Seq ByteString
+               → Maybe ([ByteString], ResourceDef)
 
       walkTree _ [] _
           = error "Internal error: should not reach here."
@@ -129,17 +128,19 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri
       walkTree tree (name:[]) soFar
           = do ResNode defM _ ← M.lookup name tree
                def            ← defM
-               return (soFar ⧺ [name], def)
+               return (toList $ soFar ⊳ name, def)
 
       walkTree tree (x:xs) soFar
           = do ResNode defM sub ← M.lookup x tree
                case defM of
                  Just (ResourceDef { resIsGreedy = True })
                      → do def ← defM
-                          return (soFar ⧺ [x], def)
-                 _   â\86\92 walkTree sub xs (soFar ⧺ [x])
+                          return (toList $ soFar ⊳ x, def)
+                 _   â\86\92 walkTree sub xs (soFar â\8a³ x)
 
-      fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
+      fallback ∷ [ByteString]
+               → [FallbackHandler]
+               → IO (Maybe ([ByteString], ResourceDef))
       fallback _    []     = return Nothing
       fallback path (x:xs) = do m ← x path
                                 case m of