1{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE FlexibleInstances, ViewPatterns #-} 4module YesodCoreTest.Links 5 ( linksTest 6 , Widget 7 , resourcesY 8 ) where 9 10import Test.Hspec 11 12import Yesod.Core 13import Network.Wai 14import Network.Wai.Test 15import Data.Text (Text) 16import Data.ByteString.Builder (toLazyByteString) 17 18data Y = Y 19mkYesod "Y" [parseRoutes| 20/ RootR GET 21/single/#Text TextR GET 22/multi/*Texts TextsR GET 23 24/route-test-1/+[Text] RT1 GET 25/route-test-2/*Vector-String RT2 GET 26/route-test-3/*Vector-(Maybe-Int) RT3 GET 27/route-test-4/#(Foo-Int-Int) RT4 GET 28/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET 29|] 30 31data Vector a = Vector 32 deriving (Show, Read, Eq) 33 34instance PathMultiPiece (Vector a) where 35 toPathMultiPiece = error "toPathMultiPiece" 36 fromPathMultiPiece = error "fromPathMultiPiece" 37 38data Foo x y = Foo 39 deriving (Show, Read, Eq) 40 41instance PathPiece (Foo x y) where 42 toPathPiece = error "toPathPiece" 43 fromPathPiece = error "fromPathPiece" 44 45instance Yesod Y 46 47getRootR :: Handler Html 48getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] 49 50getTextR :: Text -> Handler Html 51getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|] 52 53getTextsR :: [Text] -> Handler Html 54getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|] 55 56getRT1 :: [Text] -> Handler () 57getRT1 _ = return () 58 59getRT2 :: Vector String -> Handler () 60getRT2 _ = return () 61 62getRT3 :: Vector (Maybe Int) -> Handler () 63getRT3 _ = return () 64 65getRT4 :: Foo Int Int -> Handler () 66getRT4 _ = return () 67 68getRT4Spaces :: Foo Int Int -> Handler () 69getRT4Spaces _ = return () 70 71linksTest :: Spec 72linksTest = describe "Test.Links" $ do 73 it "linkToHome" case_linkToHome 74 it "blank path pieces" case_blanks 75 76runner :: Session () -> IO () 77runner f = toWaiApp Y >>= runSession f 78 79case_linkToHome :: IO () 80case_linkToHome = runner $ do 81 res <- request defaultRequest 82 assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res 83 84case_blanks :: IO () 85case_blanks = runner $ do 86 liftIO $ do 87 let go r = 88 let (ps, qs) = renderRoute r 89 in toLazyByteString $ joinPath Y "" ps qs 90 (go $ TextR "-") `shouldBe` "/single/--" 91 (go $ TextR "") `shouldBe` "/single/-" 92 (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar" 93 94 res1 <- request defaultRequest 95 { pathInfo = ["single", "-"] 96 , rawPathInfo = "dummy1" 97 } 98 assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%%</body></html>" res1 99 100 res2 <- request defaultRequest 101 { pathInfo = ["multi", "foo", "-", "bar"] 102 , rawPathInfo = "dummy2" 103 } 104 assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%["foo","","bar"]%</body></html>" res2 105