From: PHO <pho@cielonegro.org>
Date: Fri, 21 Oct 2011 04:30:17 +0000 (+0900)
Subject: Resource paths should not be assumed to be encoded in UTF-8. HTTP/1.1 says nothing... 
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=7bc27fc4e86df6cb4d269b42252de735247f8c57;p=Lucu.git

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

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa
---

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index f57a474..86b6dbd 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -20,7 +20,6 @@ import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.Sequence as S
-import Data.Text (Text)
 import Network.Socket
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.HttpVersion
@@ -34,7 +33,7 @@ data Interaction = Interaction {
     , itrLocalPort         ∷ !PortNumber
     , itrRemoteAddr        ∷ !SockAddr
     , itrRemoteCert        ∷ !(Maybe X509)
-    , itrResourcePath      ∷ !(Maybe [Text])
+    , itrResourcePath      ∷ !(Maybe [Strict.ByteString])
     , itrRequest           ∷ !(Maybe Request)
 
     , itrExpectedContinue  ∷ !(Maybe Bool)
diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index a80ecae..ecaaadb 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -26,6 +26,7 @@ import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.Socket
 import Network.URI
@@ -162,7 +163,7 @@ acceptRequestForExistentResource ∷ HandleLike h
 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
          atomically $ enqueue ctx itr
-         do _ ← runResource rsrcDef itr
+         do _ ← spawnResource rsrcDef itr
             if reqMustHaveBody $ fromJust $ itrRequest itr then
                 observeRequest ctx itr input
             else
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index eed224f..72b7517 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -205,21 +205,17 @@ getRequestVersion = reqVersion <$> getRequest
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 -- 'getResourcePath'.
 --
--- Note that the returned path is URI-decoded and then UTF-8 decoded.
-getPathInfo ∷ Resource [Text]
+-- Note that the returned path components are URI-decoded.
+getPathInfo ∷ Resource [Strict.ByteString]
 getPathInfo = do rsrcPath ← getResourcePath
                  reqPath  ← splitPathInfo <$> getRequestURI
-                 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
-                 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
-                 -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
-                 -- ければこの Resource が撰ばれた筈が無い）ので、
-                 -- rsrcPath の長さの分だけ削除すれば良い。
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request
--- body. Field names are decoded in UTF-8. See 'getForm'.
+-- body. Field names are decoded in UTF-8 for an hardly avoidable
+-- reason. See 'getForm'.
 getQueryForm ∷ Resource [(Text, FormData)]
 getQueryForm = parse' <$> getRequestURI
     where
@@ -563,8 +559,8 @@ getChunks' limit = go limit (∅)
 --
 -- Field names in @multipart\/form-data@ will be precisely decoded in
 -- accordance with RFC 2231. On the other hand,
--- @application\/x-www-form-urlencoded@ says nothing about the
--- encoding of field names, so they'll always be decoded in
+-- @application\/x-www-form-urlencoded@ says nothing about character
+-- encodings for field names, so they'll always be decoded in
 -- UTF-8. (This could be a bad design, but I can't think of any better
 -- idea.)
 getForm ∷ Maybe Int → Resource [(Text, FormData)]
diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 418a330..1d01a82 100644
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -41,7 +41,6 @@ import qualified Data.ByteString as Strict
 import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode
-import Data.Text (Text)
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
@@ -267,7 +266,7 @@ getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 -- >                        ...
 -- >   , ...
 -- >   }
-getResourcePath ∷ Resource [Text]
+getResourcePath ∷ Resource [Strict.ByteString]
 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
 
 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 9ab6f66..f3fca16 100644
--- 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)
-                 _   → walkTree sub xs (soFar ⧺ [x])
+                          return (toList $ soFar ⊳ x, def)
+                 _   → walkTree sub xs (soFar ⊳ 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
diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index c227205..82bc59b 100644
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -17,9 +17,12 @@ import Control.Monad
 import Control.Monad.Unicode
 import Control.Monad.Trans
 import qualified Data.Ascii as A
-import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
 import Data.Monoid.Unicode
+import Data.String
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import Data.Time.Clock.POSIX
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
@@ -27,7 +30,7 @@ import Network.HTTP.Lucu.ETag
 import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.MIMEType.Guess
 import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.FilePath
@@ -72,7 +75,7 @@ handleStaticFile sendContent path
            Just mime → setContentType mime
 
          when sendContent
-             $ liftIO (B.readFile path) ≫= putChunk
+             $ liftIO (LBS.readFile path) ≫= putChunks
 
 -- |@'generateETagFromFile' fpath@ generates a strong entity tag from
 -- a file. The file doesn't necessarily have to be a regular file; it
@@ -102,7 +105,8 @@ generateETagFromFile path
          return $ strongETag tag
 
 -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
--- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
+-- @dir@ and its subdirectories on the filesystem to the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
 --
 -- Note that 'staticDir' currently doesn't have a directory-listing
 -- capability. Requesting the content of a directory will end up being
@@ -115,15 +119,18 @@ staticDir path
       , resHead     = Just $ handleStaticDir False path
       }
 
+-- TODO: implement directory listing.
 handleStaticDir ∷ Bool → FilePath → Resource ()
 handleStaticDir sendContent basePath
     = do extraPath ← getPathInfo
          securityCheck extraPath
-         let path = basePath </> joinPath (map T.unpack extraPath)
-
+         let path = basePath </> joinPath (map dec8 extraPath)
          handleStaticFile sendContent path
     where
-      securityCheck pathElems
-          = when (any (≡ "..") pathElems)
-                $ fail ("security error: " ⧺ show pathElems)
--- TODO: implement directory listing.
+      dec8 ∷ ByteString → String
+      dec8 = T.unpack ∘ T.decodeUtf8
+
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+    = when (any (≡ "..") pathElems)
+          $ fail ("security error: " ⧺ show pathElems)
diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index 5102524..4db7c05 100644
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -22,8 +22,6 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
 import Data.List hiding (last)
 import Data.Monoid.Unicode
-import Data.Text (Text)
-import Data.Text.Encoding as T
 import Network.URI
 import Prelude hiding (last)
 import Prelude.Unicode
@@ -94,12 +92,12 @@ parseWWWFormURLEncoded src
 
 -- |> splitPathInfo "http://example.com/foo/bar"
 --  > ==> ["foo", "bar"]
-splitPathInfo ∷ URI → [Text]
+splitPathInfo ∷ URI → [ByteString]
 splitPathInfo uri
     = let reqPathStr = uriPath uri
           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
       in
-        map (T.decodeUtf8 ∘ BS.pack) reqPath
+        map BS.pack reqPath
 
 -- |> show3 5
 --  > ==> "005"