diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 3.1.2 + +* Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460) + ## 3.1.1 * Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988) diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs --- a/Network/Wai/Application/Static.hs +++ b/Network/Wai/Application/Static.hs @@ -40,9 +40,7 @@ import Data.Text (Text) import qualified Data.Text as T -import Data.Either (rights) import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate) -import Data.Monoid (First (First, getFirst), mconcat) import WaiAppStatic.Types import Util @@ -74,38 +72,20 @@ -- | Serve an appropriate response for a folder request. serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse -serveFolder ss@StaticSettings {..} pieces req folder@Folder {..} = - -- first check if there is an index file in this folder - case getFirst $ mconcat $ map (findIndex $ rights folderContents) ssIndices of - Just index -> - let pieces' = setLast pieces index in - case () of - () | ssRedirectToIndex -> return $ Redirect pieces' Nothing - | Just path <- addTrailingSlash req, ssAddTrailingSlash -> - return $ RawRedirect path - | otherwise -> - -- start the checking process over, with a new set - checkPieces ss pieces' req - Nothing -> - case ssListing of - Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash -> - return $ RawRedirect path - Just listing -> do - -- directory listings turned on, display it - builder <- listing pieces folder - return $ WaiResponse $ W.responseBuilder H.status200 - [ ("Content-Type", "text/html; charset=utf-8") - ] builder - Nothing -> return $ WaiResponse $ W.responseLBS H.status403 - [ ("Content-Type", "text/plain") - ] "Directory listings disabled" +serveFolder StaticSettings {..} pieces req folder@Folder {..} = + case ssListing of + Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash -> + return $ RawRedirect path + Just listing -> do + -- directory listings turned on, display it + builder <- listing pieces folder + return $ WaiResponse $ W.responseBuilder H.status200 + [ ("Content-Type", "text/html; charset=utf-8") + ] builder + Nothing -> return $ WaiResponse $ W.responseLBS H.status403 + [ ("Content-Type", "text/plain") + ] "Directory listings disabled" where - setLast :: Pieces -> Piece -> Pieces - setLast [] x = [x] - setLast [t] x - | fromPiece t == "" = [x] - setLast (a:b) x = a : setLast b x - addTrailingSlash :: W.Request -> Maybe ByteString addTrailingSlash req | S8.null rp = Just "/" @@ -114,16 +94,6 @@ where rp = W.rawPathInfo req - noTrailingSlash :: Pieces -> Bool - noTrailingSlash [] = False - noTrailingSlash [x] = fromPiece x /= "" - noTrailingSlash (_:xs) = noTrailingSlash xs - - findIndex :: [File] -> Piece -> First Piece - findIndex files index - | index `elem` map fileName files = First $ Just index - | otherwise = First Nothing - checkPieces :: StaticSettings -> Pieces -- ^ parsed request -> W.Request @@ -134,11 +104,30 @@ return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing checkPieces ss@StaticSettings {..} pieces req = do - res <- ssLookupFile pieces + res <- lookupResult case res of LRNotFound -> return NotFound LRFile file -> serveFile ss req file LRFolder folder -> serveFolder ss pieces req folder + where + lookupResult :: IO LookupResult + lookupResult = do + nonIndexResult <- ssLookupFile pieces + case nonIndexResult of + LRFile{} -> return nonIndexResult + _ -> do + indexResult <- lookupIndices (map (\ index -> pieces ++ [index]) ssIndices) + return $ case indexResult of + LRNotFound -> nonIndexResult + _ -> indexResult + + lookupIndices :: [Pieces] -> IO LookupResult + lookupIndices (x : xs) = do + res <- ssLookupFile x + case res of + LRNotFound -> lookupIndices xs + _ -> return res + lookupIndices [] = return LRNotFound serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse serveFile StaticSettings {..} req file diff --git a/test/EmbeddedTestEntries.hs b/test/EmbeddedTestEntries.hs --- a/test/EmbeddedTestEntries.hs +++ b/test/EmbeddedTestEntries.hs @@ -42,4 +42,9 @@ , EmbeddableEntry "e6.txt" "text/plain" (Right [| return ("" :: T.Text, body 1000 'W') |] ) + + -- An index file + , EmbeddableEntry "index.html" + "text/html" + (Right [| return ("" :: T.Text, "index file") |] ) ] diff --git a/test/WaiAppEmbeddedTest.hs b/test/WaiAppEmbeddedTest.hs --- a/test/WaiAppEmbeddedTest.hs +++ b/test/WaiAppEmbeddedTest.hs @@ -8,16 +8,15 @@ import Network.Wai.Test import Test.Hspec import WaiAppStatic.Storage.Embedded - -embApp :: Application -embApp = staticApp $(mkSettings mkEntries) +import WaiAppStatic.Types defRequest :: Request defRequest = defaultRequest embSpec :: Spec embSpec = do - let embed = flip runSession embApp + let embedSettings settings = flip runSession (staticApp settings) + let embed = embedSettings $(mkSettings mkEntries) describe "embedded, compressed entry" $ do it "served correctly" $ embed $ do req <- request (setRawPathInfo defRequest "e1.txt") @@ -33,6 +32,15 @@ { requestHeaders = [("If-None-Match", "Etag 1")] } assertStatus 304 req + it "ssIndices works" $ do + let testSettings = $(mkSettings mkEntries){ + ssIndices = [unsafeToPiece "index.html"] + } + embedSettings testSettings $ do + req <- request defRequest + assertStatus 200 req + assertBody "index file" req + describe "embedded, uncompressed entry" $ do it "too short" $ embed $ do req <- request (setRawPathInfo defRequest "e2.txt") @@ -75,4 +83,3 @@ assertNoHeader "Content-Encoding" req assertNoHeader "ETag" req assertBody (body 1000 'W') req - diff --git a/test/WaiAppStaticTest.hs b/test/WaiAppStaticTest.hs --- a/test/WaiAppStaticTest.hs +++ b/test/WaiAppStaticTest.hs @@ -2,11 +2,14 @@ module WaiAppStaticTest (spec) where import Network.Wai.Application.Static +import WaiAppStatic.Types import Test.Hspec import qualified Data.ByteString.Char8 as S8 -- import qualified Data.ByteString.Lazy.Char8 as L8 import System.PosixCompat.Files (getFileStatus, modificationTime) +import System.FilePath +import System.IO.Temp import Network.HTTP.Date import Network.HTTP.Types (status500) @@ -25,7 +28,8 @@ spec :: Spec spec = do let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test" - let fileServerApp = flip runSession $ staticApp (defaultFileServerSettings "test") + let fileServerAppWithSettings settings = flip runSession $ staticApp settings + let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test") { ssAddTrailingSlash = True } @@ -145,3 +149,25 @@ req <- request (setRawPathInfo defRequest "/subPath") assertStatus 301 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 diff --git a/wai-app-static.cabal b/wai-app-static.cabal --- a/wai-app-static.cabal +++ b/wai-app-static.cabal @@ -1,5 +1,5 @@ name: wai-app-static -version: 3.1.1 +version: 3.1.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -102,6 +102,8 @@ , transformers , mime-types , zlib + , filepath + , temporary -- , containers ghc-options: -Wall