diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -22,9 +22,6 @@ -- * Misc , yesodVersion , yesodRender -#if TEST - , coreTestSuite -#endif ) where import Yesod.Content @@ -59,15 +56,6 @@ 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 @@ (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 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -18,11 +18,9 @@ -- * Convert to WAI , toWaiApp , toWaiAppPlain -#if TEST - , dispatchTestSuite -#endif ) where +import Data.Either (partitionEithers) import Prelude hiding (exp) import Yesod.Core import Yesod.Handler @@ -38,7 +36,6 @@ 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 @@ -46,13 +43,6 @@ 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. @@ -126,7 +116,14 @@ [ 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 @@ -181,54 +178,9 @@ -> 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 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" - -#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 + Nothing -> yesodRunner y y id key' Nothing notFound env diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -98,9 +98,6 @@ , handlerToYAR , yarToResponse , headerToPair -#if TEST - , handlerTestSuite -#endif ) where import Prelude hiding (catch) @@ -136,10 +133,6 @@ 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) @@ -649,15 +642,6 @@ -- | Get all session variables. 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 diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs --- a/Yesod/Internal/Dispatch.hs +++ b/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 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 @@ 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) diff --git a/runtests.hs b/runtests.hs --- 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/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.7.0 +version: 0.7.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -33,7 +33,7 @@ , 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 @@ test-framework-quickcheck2, test-framework-hunit, HUnit, + wai-test, QuickCheck >= 2 && < 3 else Buildable: False