1{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
2module WaiAppStaticTest (spec) where
3
4import Network.Wai.Application.Static
5import WaiAppStatic.Types
6
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
14
15import Network.HTTP.Date
16import Network.HTTP.Types (status500)
17{-import System.Locale (defaultTimeLocale)-}
18{-import Data.Time.Format (formatTime)-}
19
20import Network.Wai
21import Network.Wai.Test
22
23import Control.Monad.IO.Class (liftIO)
24import Network.Mime
25
26defRequest :: Request
27defRequest = defaultRequest
28
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        }
36
37  let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
38  let file = "a/b"
39  let statFile = setRawPathInfo defRequest file
40
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"
48
49  describe "webApp" $ do
50    it "403 for unsafe paths" $ webApp $
51      flip mapM_ ["..", "."] $ \path ->
52        assertStatus 403 =<<
53          request (setRawPathInfo defRequest path)
54
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)
59
60    it "404 for non-existent files" $ webApp $
61      assertStatus 404 =<<
62        request (setRawPathInfo defRequest "doesNotExist")
63
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
68
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
77
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
84
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
90
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
97
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
103
104  describe "fileServerApp" $ do
105    let fileDate = do
106          stat <- liftIO $ getFileStatus $ "test/" ++ file
107          return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat
108
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
116
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
125
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
133
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
139
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
149
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
163
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
175
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
185