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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module WaiAppStaticTest (spec) where
import Network.Wai.Application.Static
import WaiAppStatic.Types
import qualified Data.ByteString.Char8 as S8
import Test.Hspec
import Test.Mockery.Directory
-- import qualified Data.ByteString.Lazy.Char8 as L8
import System.FilePath
import System.IO.Temp
import System.PosixCompat.Files (getFileStatus, modificationTime)
import Network.HTTP.Date
import Network.HTTP.Types (status500)
{-import System.Locale (defaultTimeLocale)-}
{-import Data.Time.Format (formatTime)-}
import Network.Wai
import Network.Wai.Test
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Network.Mime
defRequest :: Request
defRequest = defaultRequest
spec :: Spec
spec = do
let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"
let fileServerAppWithSettings settings = flip runSession $ staticApp settings
let fileServerApp =
fileServerAppWithSettings
(defaultFileServerSettings "test")
{ ssAddTrailingSlash = True
}
let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
let file = "a/b"
let statFile = setRawPathInfo defRequest file
describe "mime types" $ do
it "fileNameExtensions" $
fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"]
it "handles multi-extensions" $
defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz"
it "defaults correctly" $
defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream"
describe "webApp" $ do
it "403 for unsafe paths" $
webApp $
forM_ ["..", "."] $ \path ->
assertStatus 403
=<< request (setRawPathInfo defRequest path)
it "200 for hidden paths" $
webApp $
forM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->
assertStatus 200
=<< request (setRawPathInfo defRequest path)
it "404 for non-existent files" $
webApp $
assertStatus 404
=<< request (setRawPathInfo defRequest "doesNotExist")
it "302 redirect when multiple slashes" $ webApp $ do
req <- request (setRawPathInfo defRequest "a//b/c")
assertStatus 302 req
assertHeader "Location" "../../a/b/c" req
let absoluteApp =
flip runSession $
staticApp $
(defaultWebAppSettings "test")
{ ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
}
it "302 redirect when multiple slashes" $
absoluteApp $
forM_ ["/a//b/c", "a//b/c"] $ \path -> do
req <- request (setRawPathInfo defRequest path)
assertStatus 302 req
assertHeader "Location" "http://www.example.com/a/b/c" req
describe "webApp when requesting a static asset" $ do
it "200 and etag when no etag query parameters" $ webApp $ do
req <- request statFile
assertStatus 200 req
assertHeader "ETag" etag req
assertNoHeader "Last-Modified" req
it "Cache-Control set when etag parameter is correct" $ webApp $ do
req <- request statFile{queryString = [("etag", Just etag)]}
assertStatus 200 req
assertHeader "Cache-Control" "public, max-age=31536000" req
assertNoHeader "Last-Modified" req
it "200 when invalid in-none-match sent" $
webApp $
forM_ ["cached", ""] $ \badETag -> do
req <- request statFile{requestHeaders = [("If-None-Match", badETag)]}
assertStatus 200 req
assertHeader "ETag" etag req
assertNoHeader "Last-Modified" req
it "304 when valid if-none-match sent" $ webApp $ do
req <- request statFile{requestHeaders = [("If-None-Match", etag)]}
assertStatus 304 req
assertNoHeader "Etag" req
assertNoHeader "Last-Modified" req
describe "fileServerApp" $ do
let fileDate = do
stat <- liftIO $ getFileStatus $ "test/" ++ file
return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat
it "directory listing for index" $ fileServerApp $ do
resp <- request (setRawPathInfo defRequest "a/")
assertStatus 200 resp
-- note the unclosed img tags so both /> and > will pass
assertBodyContains "<img src=\"../.hidden/haskell.png\"" resp
assertBodyContains "<img src=\"../.hidden/folder.png\" alt=\"Folder\"" resp
assertBodyContains "<a href=\"b\">b</a>" resp
it "200 when invalid if-modified-since header" $ fileServerApp $ do
forM_ ["123", ""] $ \badDate -> do
req <-
request
statFile
{ requestHeaders = [("If-Modified-Since", badDate)]
}
assertStatus 200 req
fdate <- fileDate
assertHeader "Last-Modified" fdate req
it "304 when if-modified-since matches" $ fileServerApp $ do
fdate <- fileDate
req <-
request
statFile
{ requestHeaders = [("If-Modified-Since", fdate)]
}
assertStatus 304 req
assertNoHeader "Cache-Control" req
context "302 redirect to add a trailing slash on directories if missing" $ do
it "works at the root" $ fileServerApp $ do
req <- request (setRawPathInfo defRequest "/a")
assertStatus 302 req
assertHeader "Location" "/a/" req
it "works when an index.html is delivered" $ do
let settings =
(defaultFileServerSettings ".")
{ ssAddTrailingSlash = True
}
inTempDirectory $ fileServerAppWithSettings settings $ do
liftIO $ touch "foo/index.html"
req <- request (setRawPathInfo defRequest "/foo")
assertStatus 302 req
assertHeader "Location" "/foo/" req
let urlMapApp = flip runSession $ \req send ->
case pathInfo req of
"subPath" : rest ->
let req' = req{pathInfo = rest}
in ( staticApp
(defaultFileServerSettings "test")
{ ssAddTrailingSlash = True
}
)
req'
send
_ ->
send $
responseLBS
status500
[]
"urlMapApp: only works at subPath"
it "works with subpath at the root of the file server" $ urlMapApp $ do
req <- request (setRawPathInfo defRequest "/subPath")
assertStatus 302 req
assertHeader "Location" "/subPath/" req
context "with defaultWebAppSettings" $ do
it "ssIndices works" $ do
withSystemTempDirectory "wai-app-static-test" $ \dir -> do
writeFile (dir </> "index.html") "foo"
let testSettings =
(defaultWebAppSettings dir)
{ ssIndices = [unsafeToPiece "index.html"]
}
fileServerAppWithSettings testSettings $ do
resp <- request (setRawPathInfo defRequest "/")
assertStatus 200 resp
assertBody "foo" resp
context "with defaultFileServerSettings" $ do
it "prefers ssIndices over ssListing" $ do
withSystemTempDirectory "wai-app-static-test" $ \dir -> do
writeFile (dir </> "index.html") "foo"
let testSettings = defaultFileServerSettings dir
fileServerAppWithSettings testSettings $ do
resp <- request (setRawPathInfo defRequest "/")
assertStatus 200 resp
assertBody "foo" resp
|
