Commits

Luke Plant committed 7a70b8b

Added utilities for escaping URLs, and fixed bugs with addSlashRedirectProcessor

Comments (0)

Files changed (4)

src/Web/Framework/Processors.hs

 import Web.Request
 import Web.Response
 
+-- TODO -- need to include query string, and think about how to handle
+-- POSTs etc
 addSlashRedirectProcessor view req =
-    if not ("/" `isSuffixOf` pathInfo req)
-    then
-        return $ Just $ redirectResponse (pathInfo req ++ "/")
-        else view req
+    let uri = requestUriRaw req
+    in case uri of
+        Nothing -> view req -- Can't do a redirect if we don't know original URI
+        Just "" -> view req -- Don't redirect if empty
+        Just x ->  if not ("/" `isSuffixOf` x)
+                   then return $ Just $ redirectResponse (x ++ "/")
+                   else view req

src/Web/Request.hs

                    , environment
                     -- ** Constructors for Request
                    , mkRequest, buildCGIRequest
+                   -- * Escaping
+                   , escapePath
+                   , escapePathWithEnc
                    )
 
 where
 import qualified Data.ByteString.Lazy.Char8 as BS
 import qualified Data.ByteString.Lazy.UTF8 as UTF8
 import Data.Maybe
+import Network.URI (escapeURIString, isUnescapedInURI)
 import System.Environment (getEnvironment)
 import System.IO (stdin)
 
     -- ^ descriptive name of the encoding
     , decoder :: ByteString -> String
     -- ^ convert ByteString to unicode string
+    , encoder :: String -> ByteString
+    -- ^ convert unicode string to ByteString
     }
 
 instance Eq Encoding where
 utf8Encoding = Encoding {
                  name = "UTF8"
                , decoder = UTF8.toString
+               , encoder = UTF8.fromString
                }
 
 
   body <- BS.hGetContents stdin
   return $ mkRequest env body (encoding opts)
 
+
+-- | Escapes a string of bytes with percent encoding
+escapePath :: ByteString -> String
+-- Borrowed from Network.URI
+escapePath bs = escapeURIString isUnescapedInURIPath $ BS.unpack bs
+  where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"
+
+-- | Escapes a unicode string with percent encoding, using the supplied
+-- bytestring/string Encoder
+escapePathWithEnc :: String -> Encoding -> String
+escapePathWithEnc s enc = escapePath (encoder enc $ s)
+

testsuite/tests/Tests/Web/Framework.hs

 
 where
 
+import qualified Data.ByteString.Lazy.Char8 as BS
 import Test.HUnit
 import Web.Framework
 import Web.Request
 resp1 = buildResponse [ addContent "resp1" ] utf8HtmlResponse
 resp2 = buildResponse [ addContent "resp2" ] utf8HtmlResponse
 
-mkGetReq path = mkRequest [("REQUEST_METHOD","GET"),
-                           ("PATH_INFO", path)] "" utf8Encoding
+mkGetReq path = mkRequest [("REQUEST_METHOD","GET")
+                          ,("PATH_INFO", path)
+                          ,("REQUEST_URI", escapePathWithEnc path utf8Encoding)
+                          ] "" utf8Encoding
 
 alwaysFailView = const (return Nothing)
 alwaysSucceedView1 = const (return $ Just resp1)

testsuite/tests/Tests/Web/Framework/Processors.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
 module Tests.Web.Framework.Processors
 
 where
 
 import Data.Maybe (fromJust)
 import Web.Framework.Processors
+import Web.GenUtils ()
 import Web.Response
+import Web.Request
 import Test.HUnit
 import Tests.Web.Framework -- reuse view functions
 
 testAddSlashRedirectProcessor1 =
     (do
-      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkGetReq "posts")
-      return (resp == (Just $ redirectResponse "posts/"))
+      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkGetReq "/posts")
+      return (resp == (Just $ redirectResponse "/posts/"))
     ) ~? "addSlashRedirectProcessor should add a slash if not present at end"
 
 
       return (resp == (Just resp1))
     ) ~? "addSlashRedirectProcessor should not redirect if slash present at end"
 
+testAddSlashRedirectProcessor3 =
+    (do
+      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkRequest
+                                                            [("REQUEST_METHOD", "GET")
+                                                            ,("PATH_INFO", "/posts")
+                                                            ,("REQUEST_URI","/foo/posts")]
+                                                            "" utf8Encoding)
+      return (resp == (Just $ redirectResponse "/foo/posts/"))
+    ) ~? "addSlashRedirectProcessor should redirect based on request URI, not path info"
+
+
 
 tests = test [ testAddSlashRedirectProcessor1
              , testAddSlashRedirectProcessor2
+             , testAddSlashRedirectProcessor3
              ]