diff --git a/yesod-static/sample-embed.hs b/yesod-static/sample-embed.hs new file mode 100644 index 00000000..b8a53b3b --- /dev/null +++ b/yesod-static/sample-embed.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Yesod.Static +import Yesod.Dispatch +import Yesod.Core +import Network.Wai.Handler.Warp (run) + +staticFiles "." + +data Sample = Sample +getStatic _ = $(embed "tests") +mkYesod "Sample" [parseRoutes| +/ RootR GET +/static StaticR Static getStatic +|] +instance Yesod Sample where approot _ = "" + +getRootR = do + redirectText RedirectPermanent "static" + return () + +main = toWaiApp Sample >>= run 3000 diff --git a/yesod-static/sample.hs b/yesod-static/sample.hs new file mode 100644 index 00000000..9b219f2d --- /dev/null +++ b/yesod-static/sample.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Yesod.Static +import Yesod.Dispatch +import Yesod.Core +import Network.Wai.Handler.Warp (run) +import Network.Wai.Application.Static + +staticFiles "." + +data Sample = Sample +getStatic _ = Static $ defaultFileServerSettings { ssFolder = fileSystemLookup $ toFilePath "tests" } +mkYesod "Sample" [parseRoutes| +/ RootR GET +/static StaticR Static getStatic +|] +instance Yesod Sample where approot _ = "" + +getRootR = do + redirectText RedirectPermanent "static" + return () + +main = toWaiApp Sample >>= run 3000 diff --git a/yesod-static/tests/unicode/LICENSE b/yesod-static/tests/unicode/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/yesod-static/tests/unicode/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod-static/tests/unicode/README b/yesod-static/tests/unicode/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/unicode/Setup.lhs b/yesod-static/tests/unicode/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-static/tests/unicode/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-static/tests/unicode/TODO b/yesod-static/tests/unicode/TODO new file mode 100644 index 00000000..47ad1a9f --- /dev/null +++ b/yesod-static/tests/unicode/TODO @@ -0,0 +1 @@ +Add test for /static/* relative redirects diff --git a/yesod-static/tests/unicode/app.hs b/yesod-static/tests/unicode/app.hs new file mode 100644 index 00000000..6ddcde58 --- /dev/null +++ b/yesod-static/tests/unicode/app.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +import Network.Wai +import qualified Data.ByteString.Char8 as S8 +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Debug (debug) +import Network.Wai.Application.Static +import Web.Routes + +main = run 3000 $ debug app + +app req = + case decodePathInfo $ S8.unpack $ pathInfo req of + "static":"foo":rest -> staticAppPieces StaticSettings + { ssFolder = ".." + , ssIndices = [] + , ssListing = Just defaultListing + , ssGetMimeType = return . defaultMimeTypeByExt + } rest req + _ -> return $ responseLBS status404 [("Content-Type", "text/plain")] "Not found" diff --git a/yesod-static/tests/unicode/embedded-sample.hs b/yesod-static/tests/unicode/embedded-sample.hs new file mode 100644 index 00000000..29bf5a9b --- /dev/null +++ b/yesod-static/tests/unicode/embedded-sample.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp (run) +import Data.FileEmbed + +main :: IO () +main = run 3000 $ staticApp defaultStaticSettings + { ssFolder = embeddedLookup $ toEmbedded $(embedDir ".") + , ssIndices = [] + , ssMaxAge = NoMaxAge + } diff --git a/yesod-static/tests/unicode/folder.png b/yesod-static/tests/unicode/folder.png new file mode 100644 index 00000000..df13e9bd Binary files /dev/null and b/yesod-static/tests/unicode/folder.png differ diff --git a/yesod-static/tests/unicode/folder.svg b/yesod-static/tests/unicode/folder.svg new file mode 100644 index 00000000..79b25c30 --- /dev/null +++ b/yesod-static/tests/unicode/folder.svg @@ -0,0 +1,424 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + Folder Icon + + + + Jakub Steiner + + + + http://jimmac.musichall.cz + + + folder + directory + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/yesod-static/tests/unicode/haskell.png b/yesod-static/tests/unicode/haskell.png new file mode 100644 index 00000000..331501b6 Binary files /dev/null and b/yesod-static/tests/unicode/haskell.png differ diff --git a/yesod-static/tests/unicode/sample.hs b/yesod-static/tests/unicode/sample.hs new file mode 100644 index 00000000..98e791f1 --- /dev/null +++ b/yesod-static/tests/unicode/sample.hs @@ -0,0 +1,9 @@ +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = run 3000 $ staticApp defaultStaticSettings + { ssFolder = fileSystemLookup "." + , ssMaxAge = MaxAgeForever + , ssIndices = [] + } diff --git a/yesod-static/tests/unicode/test.hs b/yesod-static/tests/unicode/test.hs new file mode 100644 index 00000000..fdb5ef93 --- /dev/null +++ b/yesod-static/tests/unicode/test.hs @@ -0,0 +1,7 @@ +import Network.Wai.Application.Static + +main = do + checkPieces "." ["test.hs"] >>= print + checkPieces "." ["test.hs", ""] >>= print + checkPieces "." ["Network", ""] >>= print + checkPieces "." ["Network"] >>= print diff --git a/yesod-static/tests/unicode/tests/a/b b/yesod-static/tests/unicode/tests/a/b new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/unicode/tests/runtests.hs b/yesod-static/tests/unicode/tests/runtests.hs new file mode 100644 index 00000000..360324e3 --- /dev/null +++ b/yesod-static/tests/unicode/tests/runtests.hs @@ -0,0 +1,166 @@ +{-# 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 System.IO (stderr, hPutStrLn) + +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 } + + +-- debug :: String -> m0 () +debug = liftIO . hPutStrLn stderr + +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" [Piece "a" "a", Piece "bc" "bc"]) @?= "prefix/a/bc" + + prop "each piece is in file path" $ \piecesS -> + let pieces = map (\p -> Piece p "") piecesS + in all (\p -> ("/" ++ p) `isInfixOf` (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/yesod-static/tests/unicode/unicode.hs b/yesod-static/tests/unicode/unicode.hs new file mode 100644 index 00000000..ad3f558a --- /dev/null +++ b/yesod-static/tests/unicode/unicode.hs @@ -0,0 +1,8 @@ +import System.Directory +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Char8 as S8 + +main = getDirectoryContents "." >>= mapM_ putStrLn . map fix + +fix = T.unpack . TE.decodeUtf8 . S8.pack diff --git a/yesod-static/tests/unicode/wai-app-static.cabal b/yesod-static/tests/unicode/wai-app-static.cabal new file mode 100644 index 00000000..4e466afb --- /dev/null +++ b/yesod-static/tests/unicode/wai-app-static.cabal @@ -0,0 +1,71 @@ +name: wai-app-static +version: 0.3.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: WAI application for static serving +description: Also provides some helper functions and datatypes for use outside of WAI. +category: Web, Yesod +stability: Stable +cabal-version: >= 1.8 +build-type: Simple +homepage: http://www.yesodweb.com/ +Extra-source-files: folder.png, haskell.png + +Flag print + Description: print debug info + Default: False + +library + build-depends: base >= 4 && < 5 + , wai >= 0.4 && < 0.5 + , 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 + , containers >= 0.2 && < 0.5 + , blaze-html >= 0.4 && < 0.5 + , time >= 1.1.4 && < 1.3 + , old-locale >= 1.0.0.2 && < 1.1 + , file-embed >= 0.0.3.1 && < 0.1 + , text >= 0.5 && < 1.0 + , blaze-builder >= 0.2.1.4 && < 0.4 + , base64-bytestring >= 0.1 && < 0.2 + , cryptohash >= 0.7 && < 0.8 + , http-date + exposed-modules: Network.Wai.Application.Static + ghc-options: -Wall + extensions: CPP + + if flag(print) + cpp-options: -DPRINT + +test-suite runtests + hs-source-dirs: tests + main-is: runtests.hs + type: exitcode-stdio-1.0 + + build-depends: base >= 4 && < 5 + , hspec >= 0.6 + , HUnit + , unix-compat >= 0.2 && < 0.3 + , time >= 1.1.4 && < 1.3 + , old-locale >= 1.0.0.2 && < 1.1 + , http-date + , Cabal + , wai-app-static >= 0.3 + , wai-test + , wai + , http-types + , network + , bytestring + , text + , transformers + -- , containers + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/wai-app-static.git diff --git a/yesod-static/tests/unicode/warp.hs b/yesod-static/tests/unicode/warp.hs new file mode 100644 index 00000000..a7434ed9 --- /dev/null +++ b/yesod-static/tests/unicode/warp.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} +import Network.Wai.Application.Static + ( StaticSettings (..), staticApp, defaultMimeType, defaultListing + , defaultMimeTypes, mimeTypeByExt + ) +import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) +import System.Console.CmdArgs +import Text.Printf (printf) +import System.Directory (canonicalizePath) +import Control.Monad (unless) +import Network.Wai.Middleware.Autohead +import Network.Wai.Middleware.Debug +import Network.Wai.Middleware.Gzip +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as S8 +import Control.Arrow (second) + +data Args = Args + { docroot :: FilePath + , index :: [FilePath] + , port :: Int + , noindex :: Bool + , quiet :: Bool + , verbose :: Bool + , mime :: [(String, String)] + } + deriving (Show, Data, Typeable) + +defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] + +main :: IO () +main = do + Args {..} <- cmdArgs defaultArgs + let mime' = map (second S8.pack) mime + let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes + docroot' <- canonicalizePath docroot + args <- getArgs + unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index) + let middle = gzip False + . (if verbose then debug else id) + . autohead + run port $ middle $ staticApp StaticSettings + { ssFolder = docroot + , ssIndices = if noindex then [] else index + , ssListing = Just defaultListing + , ssGetMimeType = return . mimeTypeByExt mimeMap defaultMimeType + } diff --git a/yesod-static/tests/unicode/קרררר.html b/yesod-static/tests/unicode/קרררר.html new file mode 100644 index 00000000..2e52da08 --- /dev/null +++ b/yesod-static/tests/unicode/קרררר.html @@ -0,0 +1 @@ +

HELLO WORLD

diff --git a/yesod-static/tests/unicode/שלום b/yesod-static/tests/unicode/שלום new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/unicode/ששש/DUMMY.txt b/yesod-static/tests/unicode/ששש/DUMMY.txt new file mode 100644 index 00000000..e69de29b