git.iko.soy/typeable/wai
on warp-3.3.9-conn-closed-by-pear help sign in
typeable/wai/wai-app-static/test/WaiAppStaticTest.hs
184 lines 7.2 kB history raw
1{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
2module WaiAppStaticTest (spec) where
4import Network.Wai.Application.Static
5import WaiAppStatic.Types
7import Test.Hspec
8import Test.Mockery.Directory
9import qualified Data.ByteString.Char8 as S8
10-- import qualified Data.ByteString.Lazy.Char8 as L8
11import System.PosixCompat.Files (getFileStatus, modificationTime)
12import System.FilePath
13import System.IO.Temp
15import Network.HTTP.Date
16import Network.HTTP.Types (status500)
17{-import System.Locale (defaultTimeLocale)-}
18{-import Data.Time.Format (formatTime)-}
20import Network.Wai
21import Network.Wai.Test
23import Control.Monad.IO.Class (liftIO)
24import Network.Mime
26defRequest :: Request
27defRequest = defaultRequest
29spec :: Spec
30spec = do
31 let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"
32 let fileServerAppWithSettings settings = flip runSession $ staticApp settings
33 let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test")
34 { ssAddTrailingSlash = True
35 }
37 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
38 let file = "a/b"
39 let statFile = setRawPathInfo defRequest file
41 describe "mime types" $ do
42 it "fileNameExtensions" $
43 fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"]
44 it "handles multi-extensions" $
45 defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz"
46 it "defaults correctly" $
47 defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream"
49 describe "webApp" $ do
50 it "403 for unsafe paths" $ webApp $
51 flip mapM_ ["..", "."] $ \path ->
52 assertStatus 403 =<<
53 request (setRawPathInfo defRequest path)
55 it "200 for hidden paths" $ webApp $
56 flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->
57 assertStatus 200 =<<
58 request (setRawPathInfo defRequest path)
60 it "404 for non-existent files" $ webApp $
61 assertStatus 404 =<<
62 request (setRawPathInfo defRequest "doesNotExist")
64 it "302 redirect when multiple slashes" $ webApp $ do
65 req <- request (setRawPathInfo defRequest "a//b/c")
66 assertStatus 302 req
67 assertHeader "Location" "../../a/b/c" req
69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
71 }
72 it "302 redirect when multiple slashes" $ absoluteApp $
73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
74 req <- request (setRawPathInfo defRequest path)
75 assertStatus 302 req
76 assertHeader "Location" "http://www.example.com/a/b/c" req
78 describe "webApp when requesting a static asset" $ do
79 it "200 and etag when no etag query parameters" $ webApp $ do
80 req <- request statFile
81 assertStatus 200 req
82 assertHeader "ETag" etag req
83 assertNoHeader "Last-Modified" req
85 it "Cache-Control set when etag parameter is correct" $ webApp $ do
86 req <- request statFile { queryString = [("etag", Just etag)] }
87 assertStatus 200 req
88 assertHeader "Cache-Control" "public, max-age=31536000" req
89 assertNoHeader "Last-Modified" req
91 it "200 when invalid in-none-match sent" $ webApp $
92 flip mapM_ ["cached", ""] $ \badETag -> do
93 req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }
94 assertStatus 200 req
95 assertHeader "ETag" etag req
96 assertNoHeader "Last-Modified" req
98 it "304 when valid if-none-match sent" $ webApp $ do
99 req <- request statFile { requestHeaders = [("If-None-Match", etag)] }
100 assertStatus 304 req
101 assertNoHeader "Etag" req
102 assertNoHeader "Last-Modified" req
104 describe "fileServerApp" $ do
105 let fileDate = do
106 stat <- liftIO $ getFileStatus $ "test/" ++ file
107 return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat
109 it "directory listing for index" $ fileServerApp $ do
110 resp <- request (setRawPathInfo defRequest "a/")
111 assertStatus 200 resp
112 -- note the unclosed img tags so both /> and > will pass
113 assertBodyContains "<img src=\"../.hidden/haskell.png\"" resp
114 assertBodyContains "<img src=\"../.hidden/folder.png\" alt=\"Folder\"" resp
115 assertBodyContains "<a href=\"b\">b</a>" resp
117 it "200 when invalid if-modified-since header" $ fileServerApp $ do
118 flip mapM_ ["123", ""] $ \badDate -> do
119 req <- request statFile {
120 requestHeaders = [("If-Modified-Since", badDate)]
121 }
122 assertStatus 200 req
123 fdate <- fileDate
124 assertHeader "Last-Modified" fdate req
126 it "304 when if-modified-since matches" $ fileServerApp $ do
127 fdate <- fileDate
128 req <- request statFile {
129 requestHeaders = [("If-Modified-Since", fdate)]
130 }
131 assertStatus 304 req
132 assertNoHeader "Cache-Control" req
134 context "302 redirect to add a trailing slash on directories if missing" $ do
135 it "works at the root" $ fileServerApp $ do
136 req <- request (setRawPathInfo defRequest "/a")
137 assertStatus 302 req
138 assertHeader "Location" "/a/" req
140 it "works when an index.html is delivered" $ do
141 let settings = (defaultFileServerSettings "."){
142 ssAddTrailingSlash = True
143 }
144 inTempDirectory $ fileServerAppWithSettings settings $ do
145 liftIO $ touch "foo/index.html"
146 req <- request (setRawPathInfo defRequest "/foo")
147 assertStatus 302 req
148 assertHeader "Location" "/foo/" req
150 let urlMapApp = flip runSession $ \req send ->
151 case pathInfo req of
152 "subPath":rest ->
153 let req' = req { pathInfo = rest }
154 in (staticApp (defaultFileServerSettings "test")
155 { ssAddTrailingSlash = True
156 }) req' send
157 _ -> send $ responseLBS status500 []
158 "urlMapApp: only works at subPath"
159 it "works with subpath at the root of the file server" $ urlMapApp $ do
160 req <- request (setRawPathInfo defRequest "/subPath")
161 assertStatus 302 req
162 assertHeader "Location" "/subPath/" req
164 context "with defaultWebAppSettings" $ do
165 it "ssIndices works" $ do
166 withSystemTempDirectory "wai-app-static-test" $ \ dir -> do
167 writeFile (dir </> "index.html") "foo"
168 let testSettings = (defaultWebAppSettings dir) {
169 ssIndices = [unsafeToPiece "index.html"]
170 }
171 fileServerAppWithSettings testSettings $ do
172 resp <- request (setRawPathInfo defRequest "/")
173 assertStatus 200 resp
174 assertBody "foo" resp
176 context "with defaultFileServerSettings" $ do
177 it "prefers ssIndices over ssListing" $ do
178 withSystemTempDirectory "wai-app-static-test" $ \ dir -> do
179 writeFile (dir </> "index.html") "foo"
180 let testSettings = defaultFileServerSettings dir
181 fileServerAppWithSettings testSettings $ do
182 resp <- request (setRawPathInfo defRequest "/")
183 assertStatus 200 resp
184 assertBody "foo" resp