From 3003c9b3cdd54490a2e1c4bce11ef41aaa1eb28c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 8 Feb 2011 15:44:53 +0200 Subject: [PATCH] Beginning of new test suite --- Test/CleanPath.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++++ Yesod/Core.hs | 63 ------------------------------------- Yesod/Dispatch.hs | 47 +++------------------------- Yesod/Handler.hs | 16 ---------- runtests.hs | 9 ++---- test/.ignored | 0 test/bar/baz | 0 test/foo | 0 test/tmp/ignored | 0 9 files changed, 85 insertions(+), 129 deletions(-) create mode 100644 Test/CleanPath.hs delete mode 100644 test/.ignored delete mode 100644 test/bar/baz delete mode 100644 test/foo delete mode 100644 test/tmp/ignored diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs new file mode 100644 index 00000000..35fcc333 --- /dev/null +++ b/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 diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 81611667..5c58e931 100644 --- a/Yesod/Core.hs +++ b/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 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 43c30b21..61410011 100644 --- a/Yesod/Dispatch.hs +++ b/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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1bed488b..66127f76 100644 --- a/Yesod/Handler.hs +++ b/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 diff --git a/runtests.hs b/runtests.hs index 8498ef14..c2fc7d9d 100644 --- a/runtests.hs +++ b/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 ] diff --git a/test/.ignored b/test/.ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/test/bar/baz b/test/bar/baz deleted file mode 100644 index e69de29b..00000000 diff --git a/test/foo b/test/foo deleted file mode 100644 index e69de29b..00000000 diff --git a/test/tmp/ignored b/test/tmp/ignored deleted file mode 100644 index e69de29b..00000000