From a547ba0ac53f736d48a24b92b6edcc35e716719e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Apr 2011 21:06:37 +0300 Subject: [PATCH] Fix bug with root link --- Test/Links.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ Test/Widget.hs | 2 +- Yesod/Internal/Core.hs | 3 ++- runtests.hs | 2 ++ 4 files changed, 47 insertions(+), 2 deletions(-) create mode 100644 Test/Links.hs diff --git a/Test/Links.hs b/Test/Links.hs new file mode 100644 index 00000000..a060eadc --- /dev/null +++ b/Test/Links.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Links (linksTest) where + +import Yesod.Core hiding (Request) +import Text.Hamlet + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Network.Wai +import Network.Wai.Test + +import qualified Data.ByteString.Lazy.Char8 as L8 + +data Y = Y +mkYesod "Y" [$parseRoutes| +/ RootR GET +|] + +instance Yesod Y where + approot _ = "" + +getRootR = defaultLayout $ addHamlet [$hamlet||] + +linksTest :: Test +linksTest = testGroup "Test.Links" + [ testCase "linkToHome" case_linkToHome + ] + +runner f = toWaiApp Y >>= runSession f +defaultRequest = Request + { pathInfo = [] + , requestHeaders = [] + , queryString = [] + , requestMethod = "GET" + } + +case_linkToHome = runner $ do + res <- request defaultRequest + assertBody "\n" res diff --git a/Test/Widget.hs b/Test/Widget.hs index d9497378..8b0fcfbe 100644 --- a/Test/Widget.hs +++ b/Test/Widget.hs @@ -30,7 +30,7 @@ getRootR = defaultLayout $ addJuliusBody [$julius||] getMultiR _ = return () widgetTest :: Test -widgetTest = testGroup "Test.Exceptions" +widgetTest = testGroup "Test.Widget" [ testCase "addJuliusBody" case_addJuliusBody ] diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs index 4d817605..f6e530a3 100644 --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -210,8 +210,9 @@ class RenderRoute (Route a) => Yesod a where -> [TS.Text] -- ^ path pieces -> [(TS.Text, TS.Text)] -- ^ query string -> Builder - joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs + joinPath _ ar pieces' qs' = ar `mappend` encodePath pieces qs where + pieces = if null pieces' then [""] else pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x diff --git a/runtests.hs b/runtests.hs index f9fbb553..631f1a90 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,6 +3,7 @@ import Test.CleanPath import Test.Exceptions import Test.Widget import Test.Media +import Test.Links main :: IO () main = defaultMain @@ -10,4 +11,5 @@ main = defaultMain , exceptionsTest , widgetTest , mediaTest + , linksTest ]