Beginning of new test suite

Test/CleanPath.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Test.CleanPath (cleanPathTest) where
+
+import Yesod.Core
+import Yesod.Content
+import Yesod.Dispatch
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/foo FooR GET
+/bar BarR GET
+|]
+
+instance Yesod Y where
+    approot _ = "http://test"
+    cleanPath _ ["bar", ""] = Right ["bar"]
+    cleanPath _ ["bar"] = Left ["bar", ""]
+    cleanPath _ s =
+        if corrected == s
+            then Right s
+            else Left corrected
+      where
+        corrected = filter (not . null) s
+
+getFooR = return $ RepPlain "foo"
+getBarR = return $ RepPlain "bar"
+
+cleanPathTest :: Test
+cleanPathTest = testGroup "Test.CleanPath"
+    [ testCase "remove trailing slash" removeTrailingSlash
+    , testCase "noTrailingSlash" noTrailingSlash
+    , testCase "add trailing slash" addTrailingSlash
+    , testCase "has trailing slash" hasTrailingSlash
+    ]
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = ""
+    , requestHeaders = []
+    , queryString = ""
+    , requestMethod = "GET"
+    }
+
+removeTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/foo/"
+                }
+    assertStatus 301 res
+    assertHeader "Location" "http://test/foo" res
+
+noTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/foo"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "foo" res
+
+addTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/bar"
+                }
+    assertStatus 301 res
+    assertHeader "Location" "http://test/bar/" res
+
+hasTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = "/bar/"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "bar" res

Yesod/Core.hs

@@ -22,9 +22,6 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
-#if TEST
-    , coreTestSuite
-#endif
     ) where
 
 import Yesod.Content
@@ -59,15 +56,6 @@ import Web.Cookie (parseCookies)
 import qualified Data.Map as Map
 import Data.Time
 
-#if TEST
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit hiding (Test)
-import qualified Data.Text
-import qualified Data.Text.Encoding
-#endif
-
 #if GHC7
 #define HAMLET hamlet
 #else
@@ -486,54 +474,3 @@ yesodRender y u qs =
         (urlRenderOverride y u)
   where
     (ps, qs') = renderRoute u
-
-#if TEST
-coreTestSuite :: Test
-coreTestSuite = testGroup "Yesod.Yesod"
-    [ testProperty "join/split path" propJoinSplitPath
-    , testCase "join/split path [\".\"]" caseJoinSplitPathDquote
-    , testCase "utf8 split path" caseUtf8SplitPath
-    , testCase "utf8 join path" caseUtf8JoinPath
-    ]
-
-data TmpYesod = TmpYesod
-data TmpRoute = TmpRoute deriving Eq
-type instance Route TmpYesod = TmpRoute
-instance Yesod TmpYesod where approot _ = ""
-
-fromString :: String -> S8.ByteString
-fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack
-
-propJoinSplitPath :: [String] -> Bool
-propJoinSplitPath ss =
-    splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])
-        == Right ss'
-  where
-    ss' = filter (not . null) ss
-
-caseJoinSplitPathDquote :: Assertion
-caseJoinSplitPathDquote = do
-    splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."]
-    splitPath TmpYesod (fromString "/y./") @?= Right ["y."]
-    joinPath TmpYesod "" ["z."] [] @?= "/z./"
-    x @?= Right ss
-  where
-    x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])
-    ss' = filter (not . null) ss
-    ss = ["a."]
-
-caseUtf8SplitPath :: Assertion
-caseUtf8SplitPath = do
-    Right ["שלום"] @=?
-        splitPath TmpYesod (fromString "/שלום/")
-    Right ["page", "Fooé"] @=?
-        splitPath TmpYesod (fromString "/page/Fooé/")
-    Right ["\156"] @=?
-        splitPath TmpYesod (fromString "/\156/")
-    Right ["ð"] @=?
-        splitPath TmpYesod (fromString "/%C3%B0/")
-
-caseUtf8JoinPath :: Assertion
-caseUtf8JoinPath = do
-    "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []
-#endif

Yesod/Dispatch.hs

@@ -18,9 +18,6 @@ module Yesod.Dispatch
       -- * Convert to WAI
     , toWaiApp
     , toWaiAppPlain
-#if TEST
-    , dispatchTestSuite
-#endif
     ) where
 
 import Prelude hiding (exp)
@@ -46,13 +43,6 @@ import Data.Char (isUpper)
 
 import Web.Routes (decodePathInfo)
 
-#if TEST
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck
-import System.IO.Unsafe
-#endif
-
 -- | Generates URL datatype and site function for the given 'Resource's. This
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.
@@ -181,10 +171,10 @@ toWaiApp' :: (Yesod y, YesodDispatch y y)
           -> Maybe Key
           -> W.Application
 toWaiApp' y key' env = do
-    let segments =
-            case decodePathInfo $ B.unpack $ W.pathInfo env of
-                "":x -> x
-                x -> x
+    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 ->
@@ -203,32 +193,3 @@ toWaiApp' y key' env = do
                             [ ("Content-Type", "text/plain")
                             , ("Location", B.pack $ dest')
                             ] "Redirecting"
-
-#if TEST
-
-dispatchTestSuite :: Test
-dispatchTestSuite = testGroup "Yesod.Dispatch"
-    [ testProperty "encode/decode session" propEncDecSession
-    , testProperty "get/put time" propGetPutTime
-    ]
-
-propEncDecSession :: [(String, String)] -> Bool
-propEncDecSession session' = unsafePerformIO $ do
-    key <- getDefaultKey
-    now <- getCurrentTime
-    let expire = addUTCTime 1 now
-    let rhost = B.pack "some host"
-    let val = encodeSession key expire rhost session'
-    return $ Just session' == decodeSession key now rhost val
-
-propGetPutTime :: UTCTime -> Bool
-propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)
-
-instance Arbitrary UTCTime where
-    arbitrary = do
-        a <- arbitrary
-        b <- arbitrary
-        return $ addUTCTime (fromRational b)
-               $ UTCTime (ModifiedJulianDay a) 0
-
-#endif

Yesod/Handler.hs

@@ -98,9 +98,6 @@ module Yesod.Handler
     , handlerToYAR
     , yarToResponse
     , headerToPair
-#if TEST
-    , handlerTestSuite
-#endif
     ) where
 
 import Prelude hiding (catch)
@@ -136,10 +133,6 @@ import Data.ByteString (ByteString)
 import Data.Enumerator (Iteratee (..))
 import Network.Wai.Parse (parseHttpAccept)
 
-#if TEST
-import Test.Framework (testGroup, Test)
-#endif
-
 import Yesod.Content
 import Data.Maybe (fromMaybe)
 import Web.Cookie (SetCookie (..), renderSetCookie)
@@ -650,15 +643,6 @@ lookupSession n = GHandler $ do
 getSession :: Monad mo => GGHandler s m mo SessionMap
 getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
 
-#if TEST
-
-handlerTestSuite :: Test
-handlerTestSuite = testGroup "Yesod.Handler"
-    [
-    ]
-
-#endif
-
 handlerToYAR :: (HasReps a, HasReps b)
              => m -- ^ master site foundation
              -> s -- ^ sub site foundation

runtests.hs

@@ -1,12 +1,7 @@
 import Test.Framework (defaultMain)
-
-import Yesod.Content
-import Yesod.Dispatch
-import Yesod.Handler
+import Test.CleanPath
 
 main :: IO ()
 main = defaultMain
-    [ contentTestSuite
-    , dispatchTestSuite
-    , handlerTestSuite
+    [ cleanPathTest
     ]