diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 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) + ## 3.1.0 * Drop system-filepath 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 @@ -21,6 +21,7 @@ , ssIndices , ssMaxAge , ssRedirectToIndex + , ssAddTrailingSlash ) where import Prelude hiding (FilePath) @@ -80,14 +81,14 @@ let pieces' = setLast pieces index in case () of () | ssRedirectToIndex -> return $ Redirect pieces' Nothing - | Just path <- addTrailingSlash req -> + | 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 -> + Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash -> return $ RawRedirect path Just listing -> do -- directory listings turned on, display it diff --git a/WaiAppStatic/Listing.hs b/WaiAppStatic/Listing.hs --- a/WaiAppStatic/Listing.hs +++ b/WaiAppStatic/Listing.hs @@ -49,8 +49,12 @@ , "a { text-decoration: none }" ] H.body $ do - H.h1 $ showFolder' $ filter (not . T.null . fromPiece) pieces - renderDirectoryContentsTable haskellSrc folderSrc fps'' + let hasTrailingSlash = + case map fromPiece $ reverse $ pieces of + "":_ -> True + _ -> False + H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces + renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps'' where image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"] folderSrc = image "folder" @@ -59,17 +63,20 @@ showName x = x -- Add a link to the root of the tree - showFolder' :: Pieces -> H.Html - showFolder' pieces = showFolder (unsafeToPiece "root" : pieces) + showFolder' :: Bool -> Pieces -> H.Html + showFolder' hasTrailingSlash pieces = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces) - showFolder :: Pieces -> H.Html - showFolder [] = "/" -- won't happen - showFolder [x] = H.toHtml $ showName $ fromPiece x - showFolder (x:xs) = do - let href = concat $ replicate (length xs) "../" :: String + showFolder :: Bool -> Pieces -> H.Html + showFolder _ [] = "/" -- won't happen + showFolder _ [x] = H.toHtml $ showName $ fromPiece x + showFolder hasTrailingSlash (x:xs) = do + let len = length xs - (if hasTrailingSlash then 0 else 1) + href + | len == 0 = "." + | otherwise = concat $ replicate len "../" :: String H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x " / " :: H.Html - showFolder xs + showFolder hasTrailingSlash xs -- | a function to generate an HTML table showing the contents of a directory on the disk -- @@ -79,11 +86,12 @@ -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents' -renderDirectoryContentsTable :: String +renderDirectoryContentsTable :: [T.Text] -- ^ requested path info -> String + -> String -> [Either FolderName File] -> H.Html -renderDirectoryContentsTable haskellSrc folderSrc fps = +renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps = H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc) H.th "Name" H.th "Modified" @@ -110,7 +118,13 @@ (fromPiece -> "") -> unsafeToPiece ".." x -> x let isFile = either (const False) (const True) md - H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ H.toHtml $ fromPiece name) + href = addCurrentDir $ fromPiece name + addCurrentDir x = + case reverse pathInfo' of + "":_ -> x -- has a trailing slash + [] -> x -- at the root + currentDir:_ -> T.concat [currentDir, "/", x] + H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name) H.td ! A.class_ "date" $ H.toHtml $ case md of Right File { fileGetModified = Just t } -> diff --git a/WaiAppStatic/Storage/Filesystem.hs b/WaiAppStatic/Storage/Filesystem.hs --- a/WaiAppStatic/Storage/Filesystem.hs +++ b/WaiAppStatic/Storage/Filesystem.hs @@ -46,6 +46,7 @@ , ssIndices = [] , ssRedirectToIndex = False , ssUseHash = True + , ssAddTrailingSlash = False } -- | Settings optimized for a file server. More conservative caching will be @@ -61,6 +62,7 @@ , ssIndices = map unsafeToPiece ["index.html", "index.htm"] , ssRedirectToIndex = False , ssUseHash = False + , ssAddTrailingSlash = False } -- | Same as @defaultWebAppSettings@, but additionally uses a specialized diff --git a/WaiAppStatic/Types.hs b/WaiAppStatic/Types.hs --- a/WaiAppStatic/Types.hs +++ b/WaiAppStatic/Types.hs @@ -141,4 +141,7 @@ -- | Prefer usage of etag caching to last-modified caching. , ssUseHash :: Bool + + -- | Force a trailing slash at the end of directories + , ssAddTrailingSlash :: Bool } diff --git a/test/WaiAppStaticTest.hs b/test/WaiAppStaticTest.hs --- a/test/WaiAppStaticTest.hs +++ b/test/WaiAppStaticTest.hs @@ -25,7 +25,9 @@ spec :: Spec spec = do let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test" - let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test" + let fileServerApp = flip runSession $ staticApp (defaultFileServerSettings "test") + { ssAddTrailingSlash = True + } let etag = "1B2M2Y8AsgTpgAmY7PhCfg==" let file = "a/b" @@ -134,7 +136,9 @@ case pathInfo req of "subPath":rest -> let req' = req { pathInfo = rest } - in (staticApp $ defaultFileServerSettings "test") req' send + 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 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.0.1 +version: 3.1.1 license: MIT license-file: LICENSE author: Michael Snoyman