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