Test for correct subsite dispatch

Test/CleanPath.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Test.CleanPath (cleanPathTest) where
 
 import Yesod.Core
 import Yesod.Content
 import Yesod.Dispatch
+import Yesod.Handler (Route)
 
 import Test.Framework (defaultMain, testGroup, Test)
 import Test.Framework.Providers.HUnit
@@ -12,11 +14,28 @@ import Test.HUnit hiding (Test)
 import Network.Wai
 import Network.Wai.Test
 
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+data Subsite = Subsite
+getSubsite = const Subsite
+data SubsiteRoute = SubsiteRoute [String]
+    deriving (Eq, Show, Read)
+type instance Route Subsite = SubsiteRoute
+instance RenderRoute SubsiteRoute where
+    renderRoute (SubsiteRoute x) = (x, [])
+
+instance YesodDispatch Subsite master where
+    yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
+        status200
+        [ ("Content-Type", "SUBSITE")
+        ] $ L8.pack $ show pieces
+
 data Y = Y
 mkYesod "Y" [$parseRoutes|
 /foo FooR GET
 /foo/#String FooStringR GET
 /bar BarR GET
+/subsite SubsiteR Subsite getSubsite
 |]
 
 instance Yesod Y where
@@ -41,6 +60,7 @@ cleanPathTest = testGroup "Test.CleanPath"
     , testCase "add trailing slash" addTrailingSlash
     , testCase "has trailing slash" hasTrailingSlash
     , testCase "/foo/something" fooSomething
+    , testCase "subsite dispatch" subsiteDispatch
     ]
 
 runner f = toWaiApp Y >>= runSession f
@@ -88,3 +108,11 @@ fooSomething = runner $ do
     assertStatus 200 res
     assertContentType "text/plain; charset=utf-8" res
     assertBody "something" res
+
+subsiteDispatch = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/subsite/1/2/3/"
+                }
+    assertStatus 200 res
+    assertContentType "SUBSITE" res
+    assertBody "[\"1\",\"2\",\"3\",\"\"]" res