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 @@ -248,9 +248,9 @@ checkSpecialDirListing :: Pieces -> Maybe CheckPieces checkSpecialDirListing [".hidden", "folder.png"] = - Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")] + Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/folder.png")] checkSpecialDirListing [".hidden", "haskell.png"] = - Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")] + Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/haskell.png")] checkSpecialDirListing _ = Nothing checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function @@ -641,16 +641,14 @@ [ ("Content-Type", "text/plain") ] "File not found" -{- -The problem is that the System.Directory functions are a lie: they -claim to be using String, but it's really just a raw byte sequence. -We're assuming that non-Windows systems use UTF-8 encoding (there was -a discussion regarding this, it wasn't an arbitrary decision). So we -need to encode/decode the byte sequence to/from UTF8. That's the use -case for fixPathName/unfixPathName. I'm starting to use John -Millikin's system-filepath package for some stuff with work, and might -consider migrating over to it for this in the future. --} +-- | System.Directory functions are a lie: +-- they claim to be using String, but it's really just a raw byte sequence. +-- We're assuming that non-Windows systems use UTF-8 encoding (there was +-- a discussion regarding this, it wasn't an arbitrary decision). So we +-- need to encode/decode the byte sequence to/from UTF8. That's the use +-- case for fixPathName/unfixPathName. I'm starting to use John +-- Millikin's system-filepath package for some stuff with work, and might +-- consider migrating over to it for this in the future. toFilePath :: Prelude.FilePath -> FilePath #if defined(mingw32_HOST_OS) toFilePath = FilePath . T.pack diff --git a/folder.png b/folder.png deleted file mode 100644 Binary files a/folder.png and /dev/null differ diff --git a/haskell.png b/haskell.png deleted file mode 100644 Binary files a/haskell.png and /dev/null differ diff --git a/images/folder.png b/images/folder.png new file mode 100644 Binary files /dev/null and b/images/folder.png differ diff --git a/images/haskell.png b/images/haskell.png new file mode 100644 Binary files /dev/null and b/images/haskell.png differ diff --git a/test/WaiAppStaticTest.hs b/test/WaiAppStaticTest.hs new file mode 100644 --- /dev/null +++ b/test/WaiAppStaticTest.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} +module WaiAppStaticTest (specs) where + +import Network.Wai.Application.Static + +import Test.Hspec.Monadic +import Test.Hspec.QuickCheck +import Test.Hspec.HUnit () +import Test.HUnit ((@?=)) +import Data.List (isInfixOf) +import qualified Data.ByteString.Char8 as S8 +-- import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.PosixCompat.Files (getFileStatus, modificationTime) + +import Network.HTTP.Date +{-import System.Locale (defaultTimeLocale)-} +{-import Data.Time.Format (formatTime)-} + +import Network.Wai +import Network.Wai.Test + +import Network.Socket.Internal as Sock +import qualified Network.HTTP.Types as H +import Control.Monad.IO.Class (liftIO) + +defRequest :: Request +defRequest = Request { + rawQueryString = "" +, queryString = [] +, requestMethod = "GET" +, rawPathInfo = "" +, pathInfo = [] +, requestHeaders = [] +, serverName = "wai-test" +, httpVersion = H.http11 +, serverPort = 80 +, isSecure = False +, remoteHost = Sock.SockAddrInet 1 2 +} + +setRawPathInfo :: Request -> S8.ByteString -> Request +setRawPathInfo r rawPinfo = + let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo + in r { rawPathInfo = rawPinfo, pathInfo = pInfo } + +specs :: Specs +specs = do + let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "test"} + let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "test"} + + let etag = "1B2M2Y8AsgTpgAmY7PhCfg==" + let file = "a/b" + let statFile = setRawPathInfo defRequest file + + describe "Pieces: pathFromPieces" $ do + it "converts to a file path" $ + (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc" + + prop "each piece is in file path" $ \piecesS -> + let pieces = map (FilePath . T.pack) piecesS + in all (\p -> ("/" ++ p) `isInfixOf` (T.unpack $ unFilePath $ pathFromPieces "root" $ pieces)) piecesS + + describe "webApp" $ do + it "403 for unsafe paths" $ webApp $ + flip mapM_ ["..", "."] $ \path -> + assertStatus 403 =<< + request (setRawPathInfo defRequest path) + + it "200 for hidden paths" $ webApp $ + flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path -> + assertStatus 200 =<< + request (setRawPathInfo defRequest path) + + it "404 for non-existant files" $ webApp $ + assertStatus 404 =<< + request (setRawPathInfo defRequest "doesNotExist") + + it "301 redirect when multiple slashes" $ webApp $ do + req <- request (setRawPathInfo defRequest "a//b/c") + assertStatus 301 req + assertHeader "Location" "../../a/b/c" req + + let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings { + ssFolder = fileSystemLookup "test", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u + } + it "301 redirect when multiple slashes" $ absoluteApp $ + flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do + req <- request (setRawPathInfo defRequest path) + assertStatus 301 req + assertHeader "Location" "http://www.example.com/a/b/c" req + + describe "webApp when requesting a static asset" $ do + it "200 and etag when no etag query parameters" $ webApp $ do + req <- request statFile + assertStatus 200 req + assertNoHeader "Cache-Control" req + assertHeader "ETag" etag req + assertNoHeader "Last-Modified" req + + it "200 when no cache headers and bad cache query string" $ webApp $ do + flip mapM_ [Just "cached", Nothing] $ \badETag -> do + req <- request statFile { queryString = [("etag", badETag)] } + assertStatus 301 req + assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req + assertNoHeader "Cache-Control" req + assertNoHeader "Last-Modified" req + + it "Cache-Control set when etag parameter is correct" $ webApp $ do + req <- request statFile { queryString = [("etag", Just etag)] } + assertStatus 200 req + assertHeader "Cache-Control" "max-age=31536000" req + assertNoHeader "Last-Modified" req + + it "200 when invalid in-none-match sent" $ webApp $ + flip mapM_ ["cached", ""] $ \badETag -> do + req <- request statFile { requestHeaders = [("If-None-Match", badETag)] } + assertStatus 200 req + assertHeader "ETag" etag req + assertNoHeader "Last-Modified" req + + it "304 when valid if-none-match sent" $ webApp $ do + req <- request statFile { requestHeaders = [("If-None-Match", etag)] } + assertStatus 304 req + assertNoHeader "Etag" req + assertNoHeader "Last-Modified" req + + describe "fileServerApp" $ do + let fileDate = do + stat <- liftIO $ getFileStatus $ "test/" ++ file + return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat + + it "directory listing for index" $ fileServerApp $ do + resp <- request (setRawPathInfo defRequest "a/") + assertStatus 200 resp + -- note the unclosed img tags so both /> and > will pass + assertBodyContains "\"Folder\""b" resp + + it "200 when invalid if-modified-since header" $ fileServerApp $ do + flip mapM_ ["123", ""] $ \badDate -> do + req <- request statFile { + requestHeaders = [("If-Modified-Since", badDate)] + } + assertStatus 200 req + assertNoHeader "Cache-Control" req + fdate <- fileDate + assertHeader "Last-Modified" fdate req + + it "304 when if-modified-since matches" $ fileServerApp $ do + fdate <- fileDate + req <- request statFile { + requestHeaders = [("If-Modified-Since", fdate)] + } + assertStatus 304 req + assertNoHeader "Cache-Control" req + diff --git a/test/a/b b/test/a/b new file mode 100644 --- /dev/null +++ b/test/a/b diff --git a/tests.hs b/tests.hs new file mode 100644 --- /dev/null +++ b/tests.hs @@ -0,0 +1,5 @@ +import WaiAppStaticTest (specs) +import Test.Hspec.Monadic + +main :: IO a +main = hspecX specs diff --git a/tests/a/b b/tests/a/b deleted file mode 100644 --- a/tests/a/b +++ /dev/null diff --git a/tests/runtests.hs b/tests/runtests.hs deleted file mode 100644 --- a/tests/runtests.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} -import Network.Wai.Application.Static - -import Test.Hspec.Monadic -import Test.Hspec.QuickCheck -import Test.Hspec.HUnit () -import Test.HUnit ((@?=), assert) -import Distribution.Simple.Utils (isInfixOf) -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import System.PosixCompat.Files (getFileStatus, modificationTime) - -import Network.HTTP.Date -{-import System.Locale (defaultTimeLocale)-} -{-import Data.Time.Format (formatTime)-} - -import Network.Wai -import Network.Wai.Test - -import Network.Socket.Internal as Sock -import qualified Network.HTTP.Types as H -import Control.Monad.IO.Class (liftIO) - -defRequest :: Request -defRequest = Request { - rawQueryString = "" -, queryString = [] -, requestMethod = "GET" -, rawPathInfo = "" -, pathInfo = [] -, requestHeaders = [] -, serverName = "wai-test" -, httpVersion = H.http11 -, serverPort = 80 -, isSecure = False -, remoteHost = Sock.SockAddrInet 1 2 -} - -setRawPathInfo :: Request -> S8.ByteString -> Request -setRawPathInfo r rawPinfo = - let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo - in r { rawPathInfo = rawPinfo, pathInfo = pInfo } - - -main :: IO a -main = hspecX $ do - let must = liftIO . assert - - let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "tests"} - let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "tests"} - - let etag = "1B2M2Y8AsgTpgAmY7PhCfg==" - let file = "a/b" - let statFile = setRawPathInfo defRequest file - - - describe "Pieces: pathFromPieces" $ do - it "converts to a file path" $ - (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc" - - prop "each piece is in file path" $ \piecesS -> - let pieces = map (FilePath . T.pack) piecesS - in all (\p -> ("/" ++ p) `isInfixOf` (T.unpack $ unFilePath $ pathFromPieces "root" $ pieces)) piecesS - - describe "webApp" $ do - it "403 for unsafe paths" $ webApp $ - flip mapM_ ["..", "."] $ \path -> - assertStatus 403 =<< - request (setRawPathInfo defRequest path) - - it "200 for hidden paths" $ webApp $ - flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path -> - assertStatus 200 =<< - request (setRawPathInfo defRequest path) - - it "404 for non-existant files" $ webApp $ - assertStatus 404 =<< - request (setRawPathInfo defRequest "doesNotExist") - - it "301 redirect when multiple slashes" $ webApp $ do - req <- request (setRawPathInfo defRequest "a//b/c") - assertStatus 301 req - assertHeader "Location" "../../a/b/c" req - - let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings { - ssFolder = fileSystemLookup "tests", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u - } - it "301 redirect when multiple slashes" $ absoluteApp $ - flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do - req <- request (setRawPathInfo defRequest path) - assertStatus 301 req - assertHeader "Location" "http://www.example.com/a/b/c" req - - describe "webApp when requesting a static asset" $ do - it "200 and etag when no etag query parameters" $ webApp $ do - req <- request statFile - assertStatus 200 req - assertNoHeader "Cache-Control" req - assertHeader "ETag" etag req - assertNoHeader "Last-Modified" req - - it "200 when no cache headers and bad cache query string" $ webApp $ do - flip mapM_ [Just "cached", Nothing] $ \badETag -> do - req <- request statFile { queryString = [("etag", badETag)] } - assertStatus 301 req - assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req - assertNoHeader "Cache-Control" req - assertNoHeader "Last-Modified" req - - it "Cache-Control set when etag parameter is correct" $ webApp $ do - req <- request statFile { queryString = [("etag", Just etag)] } - assertStatus 200 req - assertHeader "Cache-Control" "max-age=31536000" req - assertNoHeader "Last-Modified" req - - it "200 when invalid in-none-match sent" $ webApp $ - flip mapM_ ["cached", ""] $ \badETag -> do - req <- request statFile { requestHeaders = [("If-None-Match", badETag)] } - assertStatus 200 req - assertHeader "ETag" etag req - assertNoHeader "Last-Modified" req - - it "304 when valid if-none-match sent" $ webApp $ do - req <- request statFile { requestHeaders = [("If-None-Match", etag)] } - assertStatus 304 req - assertNoHeader "Etag" req - assertNoHeader "Last-Modified" req - - describe "fileServerApp" $ do - let fileDate = do - stat <- liftIO $ getFileStatus $ "tests/" ++ file - return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat - - it "directory listing for index" $ fileServerApp $ do - resp <- request (setRawPathInfo defRequest "a/") - assertStatus 200 resp - let body = simpleBody resp - let contains a b = isInfixOf b (L8.unpack a) - must $ body `contains` "" - must $ body `contains` "\"Folder\"" - must $ body `contains` "b" - - it "200 when invalid if-modified-since header" $ fileServerApp $ do - flip mapM_ ["123", ""] $ \badDate -> do - req <- request statFile { - requestHeaders = [("If-Modified-Since", badDate)] - } - assertStatus 200 req - assertNoHeader "Cache-Control" req - fdate <- fileDate - assertHeader "Last-Modified" fdate req - - it "304 when if-modified-since matches" $ fileServerApp $ do - fdate <- fileDate - req <- request statFile { - requestHeaders = [("If-Modified-Since", fdate)] - } - assertStatus 304 req - assertNoHeader "Cache-Control" req - 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: 0.3.4 +version: 0.3.5 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -12,10 +12,11 @@ build-type: Simple homepage: http://www.yesodweb.com/book/wai Extra-source-files: - folder.png - haskell.png - tests/runtests.hs - tests/a/b + images/folder.png + images/haskell.png + test/WaiAppStaticTest.hs + test/a/b + tests.hs Flag print Description: print debug info @@ -27,14 +28,14 @@ , bytestring >= 0.9.1.4 && < 0.10 , http-types >= 0.6 && < 0.7 , transformers >= 0.2.2 && < 0.3 - , unix-compat >= 0.2 && < 0.3 - , directory >= 1.0 && < 1.2 + , unix-compat >= 0.2 + , directory >= 1.0.1 && < 1.2 , containers >= 0.2 && < 0.5 , blaze-html >= 0.4 && < 0.5 , time >= 1.1.4 && < 1.4 , old-locale >= 1.0.0.2 && < 1.1 , file-embed >= 0.0.3.1 && < 0.1 - , text >= 0.5 && < 1.0 + , text >= 0.7 && < 0.12 , blaze-builder >= 0.2.1.4 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , cryptohash >= 0.7 && < 0.8 @@ -47,18 +48,17 @@ cpp-options: -DPRINT test-suite runtests - hs-source-dirs: tests - main-is: runtests.hs + hs-source-dirs: test + main-is: ../tests.hs type: exitcode-stdio-1.0 build-depends: base >= 4 && < 5 - , hspec >= 0.8 && < 0.9 + , hspec >= 0.8 && < 0.10 , HUnit - , unix-compat >= 0.2 && < 0.3 + , unix-compat >= 0.2 , time >= 1.1.4 && < 1.4 , old-locale >= 1.0.0.2 && < 1.1 , http-date - , Cabal , wai-app-static >= 0.3 , wai-test , wai