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