diff --git a/Network/Wai/Application/Classic.hs b/Network/Wai/Application/Classic.hs --- a/Network/Wai/Application/Classic.hs +++ b/Network/Wai/Application/Classic.hs @@ -5,9 +5,11 @@ module Network.Wai.Application.Classic ( -- * Common ClassicAppSpec(..) + , defaultClassicAppSpec , StatusInfo(..) -- * Files , FileAppSpec(..) + , defaultFileAppSpec , FileInfo(..) , FileRoute(..) , fileApp @@ -16,6 +18,7 @@ , redirectApp -- * CGI , CgiAppSpec(..) + , defaultCgiAppSpec , CgiRoute(..) , cgiApp -- * Reverse Proxy @@ -34,3 +37,4 @@ import Network.Wai.Application.Classic.Redirect import Network.Wai.Application.Classic.RevProxy import Network.Wai.Application.Classic.Types +import Network.Wai.Application.Classic.Def diff --git a/Network/Wai/Application/Classic/Def.hs b/Network/Wai/Application/Classic/Def.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Application/Classic/Def.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Application.Classic.Def where + +import Control.Applicative +import Control.Exception +import Network.HTTP.Date +import Network.Wai.Application.Classic.Path +import Network.Wai.Application.Classic.Types +import Network.Wai.Logger +import System.Log.FastLogger.Date +import System.Posix + +-- | +-- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'logger' does not log at all. 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". +defaultClassicAppSpec :: ClassicAppSpec +defaultClassicAppSpec = ClassicAppSpec { + softwareName = "Classic" + , logger = defaultLogger + , dater = defaultDater + , statusFileDir = "/usr/local/share/html/status/" + } + +defaultLogger :: ApacheLogger +defaultLogger _ _ _ = return () + +defaultDater :: IO ZonedDate +defaultDater = formatHTTPDate . epochTimeToHTTPDate <$> epochTime + +---------------------------------------------------------------- + +-- | +-- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". 'getFileInfo' calls `getFileStatus` for every request. +defaultFileAppSpec :: FileAppSpec +defaultFileAppSpec = FileAppSpec { + indexFile = "index.html" + , isHTML = defaultIsHTml + , getFileInfo = defaultGetFileInfo + } + +defaultIsHTml :: Path -> Bool +defaultIsHTml file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file + +defaultGetFileInfo :: Path -> IO FileInfo +defaultGetFileInfo path = do + fs <- getFileStatus sfile + if not (isDirectory fs) then + return FileInfo { + fileInfoName = path + , fileInfoSize = size fs + , fileInfoTime = time fs + , fileInfoDate = formatHTTPDate (time fs) + } + else + throwIO $ userError "does not exist" + where + sfile = pathString path + size = fromIntegral . fileSize + time = epochTimeToHTTPDate . modificationTime + +---------------------------------------------------------------- + +-- | +-- Default value for 'defaultCgiAppSpec'. 'indexCgi' is \"index.cgi\". +defaultCgiAppSpec :: CgiAppSpec +defaultCgiAppSpec = CgiAppSpec { + indexCgi = "index.cgi" + } + diff --git a/Network/Wai/Application/Classic/Path.hs b/Network/Wai/Application/Classic/Path.hs --- a/Network/Wai/Application/Classic/Path.hs +++ b/Network/Wai/Application/Classic/Path.hs @@ -154,7 +154,7 @@ {-| Breaking at the first path separator. - + >>> breakAtSeparator "/foo/bar/baz" ("","/foo/bar/baz") >>> breakAtSeparator "foo/bar/baz" diff --git a/test/ClassicSpec.hs b/test/ClassicSpec.hs new file mode 100644 --- /dev/null +++ b/test/ClassicSpec.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ClassicSpec where + +import Control.Exception.Lifted +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Conduit +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as H +import Prelude hiding (catch) +import Test.Hspec + +spec :: Spec +spec = do + describe "cgiApp" $ do + it "accepts POST" $ do + let url = "http://127.0.0.1:2345/cgi-bin/echo-env/pathinfo?query=foo" + Response _ _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" + ans <- BL.readFile "test/data/post" + bdy `shouldBe` ans + it "causes 500 if the CGI script does not exist" $ do + let url = "http://127.0.0.1:2345/cgi-bin/broken" + Response sc _ _ _ <- sendPOST url "foo bar.\nbaz!\n" + sc `shouldBe` H.internalServerError500 + + describe "fileApp" $ do + it "returns index.html for /" $ do + let url = "http://127.0.0.1:2345/" + rsp <- simpleHttp url + ans <- BL.readFile "test/html/index.html" + rsp `shouldBe` ans + it "returns 400 if not exist" $ do + let url = "http://127.0.0.1:2345/dummy" + req <- parseUrl url + Response sc _ _ _ <- safeHttpLbs req + sc `shouldBe` H.notFound404 + it "returns Japanese HTML if language is specified" $ do + let url = "http://127.0.0.1:2345/ja/" + Response _ _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] + ans <- BL.readFile "test/html/ja/index.html.ja" + bdy `shouldBe` ans + it "returns 304 if not changed" $ do + let url = "http://127.0.0.1:2345/" + Response _ _ hdr _ <- sendGET url [] + let Just lm = lookup "Last-Modified" hdr + Response sc _ _ _ <- sendGET url [("If-Modified-Since", lm)] + sc `shouldBe` H.notModified304 + it "can handle partial request" $ do + let url = "http://127.0.0.1:2345/" + ans = "html>\n H.RequestHeaders -> IO (Response BL.ByteString) +sendGET url hdr = do + req' <- parseUrl url + let req = req' { requestHeaders = hdr } + safeHttpLbs req + +sendHEAD :: String -> H.RequestHeaders -> IO (Response BL.ByteString) +sendHEAD url hdr = do + req' <- parseUrl url + let req = req' { + requestHeaders = hdr + , method = "HEAD" + } + safeHttpLbs req + +sendPOST :: String -> BL.ByteString -> IO (Response BL.ByteString) +sendPOST url body = do + req' <- parseUrl url + let req = req' { + method = "POST" + , requestBody = RequestBodyLBS body + } + safeHttpLbs req + +---------------------------------------------------------------- + +safeHttpLbs :: Request (ResourceT IO) -> IO (Response BL.ByteString) +safeHttpLbs req = withManager (httpLbs req) `catch` httpHandler + +httpHandler :: HttpException -> IO (Response BL.ByteString) +httpHandler (StatusCodeException sc hd) = return (Response sc H.http11 hd BL.empty) +httpHandler _ = error "handler" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import ClassicSpec +import Control.Concurrent +import Control.Monad +import qualified Data.ByteString as BS +import Network.Wai +import Network.Wai.Application.Classic hiding (()) +import Network.Wai.Handler.Warp +import System.Directory +import System.FilePath +import Test.Hspec + +main :: IO () +main = do + void $ forkIO testServer + threadDelay 100000 + hspec spec + +testServer :: IO () +testServer = do + dir <- getCurrentDirectory + run 2345 $ testApp dir + +testApp :: FilePath -> Application +testApp dir req + | cgi = cgiApp appSpec defaultCgiAppSpec cgiRoute req + | otherwise = fileApp appSpec defaultFileAppSpec fileRoute req + where + cgi = "/cgi-bin/" `BS.isPrefixOf` rawPathInfo req + appSpec = defaultClassicAppSpec { softwareName = "ClassicTester" } + cgiRoute = CgiRoute { + cgiSrc = "/cgi-bin/" + , cgiDst = fromString (dir "test/cgi-bin/") + } + fileRoute = FileRoute { + fileSrc = "/" + , fileDst = fromString (dir "test/html/") + } diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} - -module Main where - -import Control.Exception.Lifted -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Conduit -import Network.HTTP.Conduit -import qualified Network.HTTP.Types as H -import Prelude hiding (catch) -import Test.Framework.Providers.DocTest -import Test.Framework.Providers.HUnit -import Test.Framework.TH.Prime -import Test.HUnit - ----------------------------------------------------------------- - -main :: IO () -main = $(defaultMainGenerator) - ----------------------------------------------------------------- - -doc_test :: DocTests -doc_test = docTest ["Network/Wai/Application/Classic.hs"] ["-XOverloadedStrings"] ----------------------------------------------------------------- - -case_post :: Assertion -case_post = do - Response _ _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" - ans <- BL.readFile "test/data/post" - bdy @?= ans - where - url = "http://localhost:8080/cgi-bin/echo-env/pathinfo?query=foo" - -case_post2 :: Assertion -case_post2 = do - Response sc _ _ _ <- sendPOST url "foo bar.\nbaz!\n" - sc @?= H.internalServerError500 - where - url = "http://localhost:8080/cgi-bin/broken" - ----------------------------------------------------------------- - -case_get :: Assertion -case_get = do - rsp <- simpleHttp url - ans <- BL.readFile "test/html/index.html" - rsp @?= ans - where - url = "http://localhost:8080/" - ----------------------------------------------------------------- - -case_get2 :: Assertion -case_get2 = do - req <- parseUrl url - Response sc _ _ _ <- safeHttpLbs req - sc @?= H.notFound404 - where - url = "http://localhost:8080/dummy" - ----------------------------------------------------------------- - -case_get_ja :: Assertion -case_get_ja = do - Response _ _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] - ans <- BL.readFile "test/html/ja/index.html.ja" - bdy @?= ans - where - url = "http://localhost:8080/ja/" - ----------------------------------------------------------------- - -case_get_modified :: Assertion -case_get_modified = do - Response _ _ hdr _ <- sendGET url [] - let Just lm = lookup "Last-Modified" hdr - Response sc _ _ _ <- sendGET url [("If-Modified-Since", lm)] - sc @?= H.notModified304 - where - url = "http://localhost:8080/" - ----------------------------------------------------------------- - -case_get_partial :: Assertion -case_get_partial = do - Response _ _ _ bdy <- sendGET url [("Range", "bytes=10-20")] - bdy @?= ans - where - url = "http://localhost:8080/" - ans = "html>\n H.RequestHeaders -> IO (Response BL.ByteString) -sendGET url hdr = do - req' <- parseUrl url - let req = req' { requestHeaders = hdr } - safeHttpLbs req - ----------------------------------------------------------------- - -sendHEAD :: String -> H.RequestHeaders -> IO (Response BL.ByteString) -sendHEAD url hdr = do - req' <- parseUrl url - let req = req' { - requestHeaders = hdr - , method = "HEAD" - } - safeHttpLbs req - ----------------------------------------------------------------- - -sendPOST :: String -> BL.ByteString -> IO (Response BL.ByteString) -sendPOST url body = do - req' <- parseUrl url - let req = req' { - method = "POST" - , requestBody = RequestBodyLBS body - } - safeHttpLbs req - ----------------------------------------------------------------- - -safeHttpLbs :: Request (ResourceT IO) -> IO (Response BL.ByteString) -safeHttpLbs req = withManager (httpLbs req) `catch` httpHandler - ----------------------------------------------------------------- - -httpHandler :: HttpException -> IO (Response BL.ByteString) -httpHandler (StatusCodeException sc hd) = return (Response sc H.http11 hd BL.empty) -httpHandler _ = error "handler" diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-XOverloadedStrings" + , "Network/Wai/Application/Classic.hs" + ] diff --git a/wai-app-file-cgi.cabal b/wai-app-file-cgi.cabal --- a/wai-app-file-cgi.cabal +++ b/wai-app-file-cgi.cabal @@ -1,5 +1,5 @@ Name: wai-app-file-cgi -Version: 0.8.0 +Version: 0.8.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -9,14 +9,16 @@ executes CGI scripts, and serves as a reverse proxy. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Web, Yesod -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Build-Type: Simple Library + Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.Wai.Application.Classic Other-Modules: Network.Wai.Application.Classic.CGI Network.Wai.Application.Classic.Conduit + Network.Wai.Application.Classic.Def Network.Wai.Application.Classic.EventSource Network.Wai.Application.Classic.Field Network.Wai.Application.Classic.File @@ -57,21 +59,37 @@ , unix , wai >= 1.2 , wai-logger + , word8 -Test-Suite test - Main-Is: Test.hs +Test-Suite doctest Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 HS-Source-Dirs: test - Build-Depends: base >= 4 && < 5 + Ghc-Options: -threaded -Wall + Main-Is: doctests.hs + Build-Depends: base + , doctest >= 0.9.3 + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + HS-Source-Dirs: test + Ghc-Options: -threaded -Wall + Main-Is: Spec.hs + Other-Modules: ClassicSpec + Build-Depends: base , bytestring - , conduit >= 0.5 && < 0.6 + , conduit + , directory + , filepath + , hspec >= 1.3 , http-conduit , http-types , lifted-base - , HUnit - , test-framework-doctest - , test-framework-hunit - , test-framework-th-prime + , unix + , wai + , wai-app-file-cgi + , warp Source-Repository head Type: git