haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix bug with root link

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-10 21:06:37 +03:00
parent 1948a9a429
commit a547ba0ac5
4 changed files with 47 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
Test/Links.hs Normal file
View File

@ -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|<a href=@{RootR}>|]
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 "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res

2
Test/Widget.hs
View File

@ -30,7 +30,7 @@ getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
getMultiR _ = return () getMultiR _ = return ()
widgetTest :: Test widgetTest :: Test
widgetTest = testGroup "Test.Exceptions" widgetTest = testGroup "Test.Widget"
[ testCase "addJuliusBody" case_addJuliusBody [ testCase "addJuliusBody" case_addJuliusBody
] ]

3
Yesod/Internal/Core.hs
View File

@ -210,8 +210,9 @@ class RenderRoute (Route a) => Yesod a where
-> [TS.Text] -- ^ path pieces -> [TS.Text] -- ^ path pieces
-> [(TS.Text, TS.Text)] -- ^ query string -> [(TS.Text, TS.Text)] -- ^ query string
-> Builder -> Builder
joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs joinPath _ ar pieces' qs' = ar `mappend` encodePath pieces qs
where where
pieces = if null pieces' then [""] else pieces'
qs = map (TE.encodeUtf8 *** go) qs' qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing go "" = Nothing
go x = Just $ TE.encodeUtf8 x go x = Just $ TE.encodeUtf8 x

2
runtests.hs
View File

@ -3,6 +3,7 @@ import Test.CleanPath
import Test.Exceptions import Test.Exceptions
import Test.Widget import Test.Widget
import Test.Media import Test.Media
import Test.Links
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
@ -10,4 +11,5 @@ main = defaultMain
, exceptionsTest , exceptionsTest
, widgetTest , widgetTest
, mediaTest , mediaTest
, linksTest
] ]