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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE CPP #-}
module YesodCoreTest.CleanPath
( cleanPathTest
, Widget
, resourcesY
) where
import Test.Hspec
import Yesod.Core
import Network.Wai
import Network.Wai.Test
import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import Control.Arrow ((***))
import Network.HTTP.Types (encodePath)
import Data.Monoid (mappend)
import Data.Text.Encoding (encodeUtf8Builder)
data Subsite = Subsite
getSubsite :: a -> Subsite
getSubsite = const Subsite
instance RenderRoute Subsite where
data Route Subsite = SubsiteRoute [TS.Text]
deriving (Eq, Show, Read)
renderRoute (SubsiteRoute x) = (x, [])
instance ParseRoute Subsite where
parseRoute (x, _) = Just $ SubsiteRoute x
instance YesodSubDispatch Subsite master where
yesodSubDispatch _ req f = f $ responseLBS
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show (pathInfo req)
data Y = Y
mkYesod "Y" [parseRoutes|
/foo FooR GET
/foo/#String FooStringR GET
/bar BarR GET
/subsite SubsiteR Subsite getSubsite
/plain PlainR GET
|]
instance Yesod Y where
approot = ApprootStatic "http://test"
cleanPath _ s@("subsite":_) = Right s
cleanPath _ ["bar", ""] = Right ["bar"]
cleanPath _ ["bar"] = Left ["bar", ""]
cleanPath _ s =
if corrected == s
then Right s
else Left corrected
where
corrected = filter (not . TS.null) s
joinPath Y ar pieces' qs' =
encodeUtf8Builder ar `Data.Monoid.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
getFooR :: Handler RepPlain
getFooR = return $ RepPlain "foo"
getFooStringR :: String -> Handler RepPlain
getFooStringR = return . RepPlain . toContent
getBarR, getPlainR :: Handler RepPlain
getBarR = return $ RepPlain "bar"
getPlainR = return $ RepPlain "plain"
cleanPathTest :: Spec
cleanPathTest =
describe "Test.CleanPath" $ do
it "remove trailing slash" removeTrailingSlash
it "noTrailingSlash" noTrailingSlash
it "add trailing slash" addTrailingSlash
it "has trailing slash" hasTrailingSlash
it "/foo/something" fooSomething
it "subsite dispatch" subsiteDispatch
it "redirect with query string" redQueryString
it "parsing" $ do
parseRoute (["foo"], []) `shouldBe` Just FooR
parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar")
parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"])
parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y))
runner :: Session () -> IO ()
runner f = toWaiApp Y >>= runSession f
removeTrailingSlash :: IO ()
removeTrailingSlash = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/foo/"
}
assertStatus 301 res
assertHeader "Location" "http://test/foo" res
noTrailingSlash :: IO ()
noTrailingSlash = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/foo"
}
assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res
assertBody "foo" res
addTrailingSlash :: IO ()
addTrailingSlash = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/bar"
}
assertStatus 301 res
assertHeader "Location" "http://test/bar/" res
hasTrailingSlash :: IO ()
hasTrailingSlash = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/bar/"
}
assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res
assertBody "bar" res
fooSomething :: IO ()
fooSomething = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/foo/something"
}
assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res
assertBody "something" res
subsiteDispatch :: IO ()
subsiteDispatch = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/subsite/1/2/3/"
}
assertStatus 200 res
assertContentType "SUBSITE" res
assertBody "[\"1\",\"2\",\"3\",\"\"]" res
redQueryString :: IO ()
redQueryString = runner $ do
res <- request defaultRequest
{ pathInfo = decodePathSegments "/plain/"
, rawQueryString = "?foo=bar"
}
assertStatus 301 res
assertHeader "Location" "http://test/plain?foo=bar" res
|
