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>%[&quot;foo&quot;,&quot;&quot;,&quot;bar&quot;]%</body></html>" res2
105