Proper cleanPath behavior

Test/CleanPath.hs

@@ -15,6 +15,7 @@ import Network.Wai.Test
 data Y = Y
 mkYesod "Y" [$parseRoutes|
 /foo FooR GET
+/foo/#String FooStringR GET
 /bar BarR GET
 |]
 
@@ -30,6 +31,7 @@ instance Yesod Y where
         corrected = filter (not . null) s
 
 getFooR = return $ RepPlain "foo"
+getFooStringR = return . RepPlain . toContent
 getBarR = return $ RepPlain "bar"
 
 cleanPathTest :: Test
@@ -38,6 +40,7 @@ cleanPathTest = testGroup "Test.CleanPath"
     , testCase "noTrailingSlash" noTrailingSlash
     , testCase "add trailing slash" addTrailingSlash
     , testCase "has trailing slash" hasTrailingSlash
+    , testCase "/foo/something" fooSomething
     ]
 
 runner f = toWaiApp Y >>= runSession f
@@ -77,3 +80,11 @@ hasTrailingSlash = runner $ do
     assertStatus 200 res
     assertContentType "text/plain; charset=utf-8" res
     assertBody "bar" res
+
+fooSomething = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/foo/something"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "something" res

Yesod/Dispatch.hs

@@ -20,6 +20,7 @@ module Yesod.Dispatch
     , toWaiAppPlain
     ) where
 
+import Data.Either (partitionEithers)
 import Prelude hiding (exp)
 import Yesod.Core
 import Yesod.Handler
@@ -35,7 +36,6 @@ import Network.Wai.Middleware.Jsonp
 import Network.Wai.Middleware.Gzip
 
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString as S
 import Data.ByteString.Lazy.Char8 ()
 
 import Web.ClientSession
@@ -116,7 +116,14 @@ mkYesodGeneral name args clazzes isSub res = do
                 [ FunD (mkName "renderRoute") render
                 ]
 
-    yd <- mkYesodDispatch' th'
+    let splitter :: (THResource, Maybe String)
+                 -> Either
+                        (THResource, Maybe String)
+                        (THResource, Maybe String)
+        splitter a@((_, SubSite{}), _) = Left a
+        splitter a = Right a
+    let (resSub, resLoc) = partitionEithers $ map splitter th'
+    yd <- mkYesodDispatch' resSub resLoc
     let master = mkName "master"
     let ctx = if isSub
                 then ClassP (mkName "Yesod") [VarT master] : clazzes
@@ -174,22 +181,6 @@ toWaiApp' y key' env = do
     let dropSlash ('/':x) = x
         dropSlash x = x
     let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env
-    -- FIXME cleanPath will not force redirect if yesodDispatch likes its arguments
     case yesodDispatch y key' segments y id of
         Just app -> app env
-        Nothing ->
-            case cleanPath y segments of
-                Right segments' ->
-                    case yesodDispatch y key' segments' y id of
-                        Just app -> app env
-                        Nothing -> yesodRunner y y id key' Nothing notFound env
-                Left segments' ->
-                    let dest = joinPath y (approot y) segments' []
-                        dest' =
-                            if S.null (W.queryString env)
-                                then dest
-                                else dest ++ '?' : B.unpack (W.queryString env)
-                     in return $ W.responseLBS W.status301
-                            [ ("Content-Type", "text/plain")
-                            , ("Location", B.pack $ dest')
-                            ] "Redirecting"
+        Nothing -> yesodRunner y y id key' Nothing notFound env

Yesod/Internal/Dispatch.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 -- | A bunch of Template Haskell used in the Yesod.Dispatch module.
 module Yesod.Internal.Dispatch
     ( mkYesodDispatch'
@@ -17,6 +18,9 @@ import Yesod.Core (yesodRunner, yesodDispatch)
 import Data.List (foldl')
 import Data.Char (toLower)
 import qualified Data.ByteString.Char8 as S8
+import Data.ByteString.Lazy.Char8 ()
+import qualified Data.ByteString as S
+import Yesod.Core (Yesod (joinPath, approot, cleanPath))
 
 {-|
 
@@ -64,16 +68,52 @@ case segments of
 Obviously we would never want to write code by hand like this, but generating it is not too bad.
 
 This function generates a clause for the yesodDispatch function based on a set of routes.
+
+NOTE: We deal with subsites first; if none of those match, we try to apply
+cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
+local routes.
+
 -}
-mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause
-mkYesodDispatch' res = do
+
+sendRedirect :: Yesod master => master -> [String] -> W.Application
+sendRedirect y segments' env =
+     return $ W.responseLBS W.status301
+            [ ("Content-Type", "text/plain")
+            , ("Location", S8.pack $ dest')
+            ] "Redirecting"
+  where
+    dest = joinPath y (approot y) segments' []
+    dest' =
+        if S.null (W.queryString env)
+            then dest
+            else dest ++ '?' : S8.unpack (W.queryString env)
+
+mkYesodDispatch' :: [((String, Pieces), Maybe String)]
+                 -> [((String, Pieces), Maybe String)]
+                 -> Q Clause
+mkYesodDispatch' resSub resLoc = do
     sub <- newName "sub"
     master <- newName "master"
     mkey <- newName "mkey"
     segments <- newName "segments"
+    segments' <- newName "segmentsClean"
     toMasterRoute <- newName "toMasterRoute"
     nothing <- [|Nothing|]
-    body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res
+    bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
+    cp <- [|cleanPath|]
+    sr <- [|sendRedirect|]
+    just <- [|Just|]
+    let bodyLoc' =
+            CaseE (cp `AppE` VarE master `AppE` VarE segments)
+                [ Match (ConP (mkName "Left") [VarP segments'])
+                        (NormalB $ just `AppE`
+                           (sr `AppE` VarE master `AppE` VarE segments'))
+                        []
+                , Match (ConP (mkName "Right") [VarP segments'])
+                        (NormalB bodyLoc)
+                        []
+                ]
+    body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
     return $ Clause
         [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
         (NormalB body)

yesod-core.cabal

@@ -33,7 +33,7 @@ library
                    , bytestring                >= 0.9.1.4  && < 0.10
                    , text                      >= 0.5      && < 0.12
                    , template-haskell
-                   , web-routes-quasi          >= 0.6.3    && < 0.7
+                   , web-routes-quasi          >= 0.6.3.1  && < 0.7
                    , hamlet                    >= 0.7      && < 0.8
                    , blaze-builder             >= 0.2.1    && < 0.3
                    , transformers              >= 0.2      && < 0.3
@@ -74,6 +74,7 @@ executable             runtests
                        test-framework-quickcheck2,
                        test-framework-hunit,
                        HUnit,
+                       wai-test,
                        QuickCheck >= 2 && < 3
     else
         Buildable: False