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 @@ -9,14 +9,20 @@ -- * Files , FileAppSpec(..) , FileInfo(..) - , FileRoute(..), fileApp + , FileRoute(..) + , fileApp -- * CGI - , CgiRoute(..), cgiApp + , CgiAppSpec(..) + , CgiRoute(..) + , cgiApp -- * Reverse Proxy , RevProxyAppSpec(..) - , RevProxyRoute(..), revProxyApp + , RevProxyRoute(..) + , revProxyApp -- * Path , module Network.Wai.Application.Classic.Path + -- * Misc + , redirectHeader ) where import Network.Wai.Application.Classic.CGI diff --git a/Network/Wai/Application/Classic/CGI.hs b/Network/Wai/Application/Classic/CGI.hs --- a/Network/Wai/Application/Classic/CGI.hs +++ b/Network/Wai/Application/Classic/CGI.hs @@ -44,17 +44,17 @@ > installHandler sigCHLD Ignore Nothing -} -cgiApp :: ClassicAppSpec -> CgiRoute -> Application -cgiApp cspec cgii req = case method of - "GET" -> cgiApp' False cspec cgii req - "POST" -> cgiApp' True cspec cgii req +cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application +cgiApp cspec spec cgii req = case method of + "GET" -> cgiApp' False cspec spec cgii req + "POST" -> cgiApp' True cspec spec cgii req _ -> return $ responseLBS statusNotAllowed textPlainHeader "Method Not Allowed\r\n" -- xxx where method = requestMethod req -cgiApp' :: Bool -> ClassicAppSpec -> CgiRoute -> Application -cgiApp' body cspec cgii req = do - (rhdl,whdl,tellEOF) <- liftIO (execProcess cspec cgii req) >>= register3 +cgiApp' :: Bool -> ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application +cgiApp' body cspec spec cgii req = do + (rhdl,whdl,tellEOF) <- liftIO (execProcess cspec spec cgii req) >>= register3 when body $ toCGI whdl req tellEOF fromCGI rhdl cspec req @@ -92,8 +92,8 @@ ---------------------------------------------------------------- -execProcess :: ClassicAppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle) -execProcess cspec cgii req = do +execProcess :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle) +execProcess cspec spec cgii req = do let naddr = showSockAddr . remoteHost $ req (Just whdl,Just rhdl,_,pid) <- createProcess . proSpec $ naddr hSetEncoding rhdl latin1 @@ -112,9 +112,11 @@ , create_group = True #endif } - (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) - (cgiDst cgii) - (fromByteString (rawPathInfo req)) + (prog, scriptName, pathinfo) = + pathinfoToCGI (cgiSrc cgii) + (cgiDst cgii) + (fromByteString (rawPathInfo req)) + (indexCgi spec) makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> ENVVARS makeEnv req naddr scriptName pathinfo sname = addLen . addType . addCookie $ baseEnv @@ -144,11 +146,24 @@ addEnv _ Nothing envs = envs addEnv key (Just val) envs = (key,BS.unpack val) : envs -pathinfoToCGI :: Path -> Path -> Path -> (FilePath, String, String) -pathinfoToCGI src dst path = (prog, scriptName, pathinfo) +{-| + +>>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/foo" "index.cgi" +("/User/cgi-bin/foo","/cgi-bin/foo","") +>>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/foo/bar" "index.cgi" +("/User/cgi-bin/foo","/cgi-bin/foo","/bar") +>>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/" "index.cgi" +("/User/cgi-bin/index.cgi","/cgi-bin/index.cgi","") + +-} + +pathinfoToCGI :: Path -> Path -> Path -> Path -> (FilePath, String, String) +pathinfoToCGI src dst path index = (prog, scriptName, pathinfo) where path' = path <\> src - (prog',pathinfo') = breakAtSeparator path' + (prog',pathinfo') + | src == path = (index, "") + | otherwise = breakAtSeparator path' prog = pathString (dst prog') scriptName = pathString (src prog') pathinfo = pathString pathinfo' diff --git a/Network/Wai/Application/Classic/File.hs b/Network/Wai/Application/Classic/File.hs --- a/Network/Wai/Application/Classic/File.hs +++ b/Network/Wai/Application/Classic/File.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.File ( fileApp + , redirectHeader ) where import Control.Applicative -import Control.Exception (Exception, SomeException) -import Control.Exception.Lifted (catch, throwIO) import Control.Monad.IO.Class (liftIO) +import Data.Alternative.IO.Lifted +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS (pack, concat) import qualified Data.ByteString.Lazy.Char8 as BL (length) import Data.Conduit -import Data.Typeable import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field @@ -25,23 +23,8 @@ ---------------------------------------------------------------- -type RIO = ResourceT IO type Rsp = ResourceT IO RspSpec -instance Alternative RIO where - empty = goNext - x <|> y = x `catch` (\(_ :: SomeException) -> y) - -data RIOErr = RIOErr deriving (Show, Typeable) - -instance Exception RIOErr - -goNext :: RIO a -goNext = throwIO RIOErr - -runAlt :: [RIO a] -> RIO a -runAlt = foldr (<|>) goNext - ---------------------------------------------------------------- data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] @@ -122,17 +105,17 @@ processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp processGET hinfo ishtml rfile = tryGet hinfo ishtml - <|> tryRedirect hinfo rfile - <|> return notFound + <||> tryRedirect hinfo rfile + <||> return notFound tryGet :: HandlerInfo -> Bool -> Rsp tryGet hinfo@(HandlerInfo _ _ _ langs) True = - runAlt $ map (tryGetFile hinfo True) langs + runAnyOne $ map (tryGetFile hinfo True) langs tryGet hinfo False = tryGetFile hinfo False id tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp tryGetFile (HandlerInfo spec req file _) ishtml lang = do - finfo <- liftIO (getFileInfo spec (lang file)) + finfo <- liftIO $ (getFileInfo spec) (lang file) let mtime = fileInfoTime finfo size = fileInfoSize finfo sfile = fileInfoName finfo @@ -151,17 +134,17 @@ processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp processHEAD hinfo ishtml rfile = tryHead hinfo ishtml - <|> tryRedirect hinfo rfile - <|> return notFoundNoBody + <||> tryRedirect hinfo rfile + <||> return notFoundNoBody tryHead :: HandlerInfo -> Bool -> Rsp tryHead hinfo@(HandlerInfo _ _ _ langs) True = - runAlt $ map (tryHeadFile hinfo True) langs + runAnyOne $ map (tryHeadFile hinfo True) langs tryHead hinfo False= tryHeadFile hinfo False id tryHeadFile :: HandlerInfo -> Bool -> Lang -> Rsp tryHeadFile (HandlerInfo spec req file _) ishtml lang = do - finfo <- liftIO (getFileInfo spec (lang file)) + finfo <- liftIO $ (getFileInfo spec) (lang file) let mtime = fileInfoTime finfo size = fileInfoSize finfo hdr = newHeader ishtml (pathByteString file) mtime @@ -176,23 +159,29 @@ tryRedirect :: HandlerInfo -> Maybe Path -> Rsp tryRedirect _ Nothing = goNext tryRedirect (HandlerInfo spec req _ langs) (Just file) = - runAlt $ map (tryRedirectFile hinfo) langs + runAnyOne $ map (tryRedirectFile hinfo) langs where hinfo = HandlerInfo spec req file langs tryRedirectFile :: HandlerInfo -> Lang -> Rsp tryRedirectFile (HandlerInfo spec req file _) lang = do - _ <- liftIO $ getFileInfo spec (lang file) + _ <- liftIO $ (getFileInfo spec) (lang file) return $ RspSpec statusMovedPermanently (BodyFileNoBody hdr) where - hdr = locationHeader redirectURL - redirectURL = BS.concat [ "http://" - , serverName req - , ":" - , (BS.pack . show . serverPort) req - , rawPathInfo req - , "/" - ] + hdr = redirectHeader req + +redirectHeader :: Request -> ResponseHeaders +redirectHeader = locationHeader . redirectURL + +redirectURL :: Request -> ByteString +redirectURL req = BS.concat [ + "http://" + , serverName req + , ":" + , (BS.pack . show . serverPort) req + , rawPathInfo req + , "/" + ] ---------------------------------------------------------------- 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 @@ -15,13 +15,15 @@ import Data.Monoid import Data.String import Data.Word +import Data.Function ---------------------------------------------------------------- +-- | Smart file path. data Path = Path { pathString :: FilePath , pathByteString :: ByteString - } deriving Show + } instance IsString Path where fromString path = Path { @@ -29,6 +31,14 @@ , pathByteString = BS.pack path } +instance Show Path where + show = show . pathByteString + +instance Eq Path where + (==) = (==) `on` pathByteString + +---------------------------------------------------------------- + fromByteString :: ByteString -> Path fromByteString path = Path { pathString = BS.unpack path @@ -43,6 +53,11 @@ {-| Checking if the path ends with the path separator. + +>>> hasTrailingPathSeparator "/foo/bar/" +True +>>> hasTrailingPathSeparator "/foo/bar" +False -} hasTrailingPathSeparator :: Path -> Bool hasTrailingPathSeparator path @@ -68,6 +83,11 @@ {-| Appending with the file separator. + +>>> "/foo" "bar" +"/foo/bar" +>>> "/foo/" "bar" +"/foo/bar" -} () :: Path -> Path -> Path @@ -87,6 +107,13 @@ {-| Removing prefix. The prefix of the second argument is removed from the first argument. + +>>> "foobar" <\> "foo" +"bar" +>>> "foo" <\> "foobar" +"" +>>> "foobar" <\> "baz" +"bar" -} (<\>) :: Path -> Path -> Path p1 <\> p2 = Path { @@ -115,6 +142,13 @@ {-| Breaking at the first path separator. + +>>> breakAtSeparator "/foo/bar/baz" +("","/foo/bar/baz") +>>> breakAtSeparator "foo/bar/baz" +("foo","/bar/baz") +>>> breakAtSeparator "foo" +("foo","") -} breakAtSeparator :: Path -> (Path,Path) breakAtSeparator p = (fromByteString r1, fromByteString r2) diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs --- a/Network/Wai/Application/Classic/Status.hs +++ b/Network/Wai/Application/Classic/Status.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where import Control.Applicative import Control.Arrow import Control.Exception +import Data.Alternative.IO import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import Data.Maybe @@ -14,13 +14,6 @@ import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types import Prelude hiding (catch) - -instance Alternative IO where - empty = goNext - x <|> y = x `catch` (\(_ :: SomeException) -> y) - -goNext :: IO a -goNext = throwIO $ userError "goNext for IO" ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Types.hs b/Network/Wai/Application/Classic/Types.hs --- a/Network/Wai/Application/Classic/Types.hs +++ b/Network/Wai/Application/Classic/Types.hs @@ -6,7 +6,7 @@ import Network.HTTP.Date import Network.HTTP.Types import Network.Wai.Application.Classic.Path -import Network.Wai.Logger.Prefork +import Network.Wai.Logger ---------------------------------------------------------------- @@ -35,7 +35,7 @@ -- | Whether this is an HTML or not. , isHTML :: Path -> Bool -- | A function to obtain information about a file. - -- | If information is not obtained, an IO exception should be raised. + -- If information is not obtained, an IO exception should be raised. , getFileInfo :: Path -> IO FileInfo } @@ -53,6 +53,11 @@ } ---------------------------------------------------------------- + +data CgiAppSpec = CgiAppSpec { + -- | A file name of the default CGI. + indexCgi :: Path + } data CgiRoute = CgiRoute { -- | Path prefix to be matched to 'rawPathInfo'. diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + +module Main where + +import Control.Exception.Lifted +import qualified Data.ByteString.Lazy.Char8 as BL +import Network.HTTP.Conduit +import Network.HTTP.Date +import qualified Network.HTTP.Types as H +import Network.Wai.Application.Classic.Header +import Network.Wai.Application.Classic.Lang +import Network.Wai.Application.Classic.Range +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_lang :: Assertion +case_lang = do + let res = parseLang "en-gb;q=0.8, en;q=0.7, da" + res @?= ans + where + ans = ["da","en-gb","en"] + +---------------------------------------------------------------- + +case_date :: Assertion +case_date = do + let Just x = parseHTTPDate date + res = formatHTTPDate x + res @?= date + where + date = "Tue, 15 Nov 1994 08:12:31 GMT" + +---------------------------------------------------------------- + +case_range :: Assertion +case_range = do + let res1 = skipAndSize range1 size + res2 = skipAndSize range2 size + res3 = skipAndSize range3 size + res4 = skipAndSize range4 size + res1 @?= ans1 + res2 @?= ans2 + res3 @?= ans3 + res4 @?= ans4 + where + size = 10000 + range1 = "bytes=0-399" + range2 = "bytes=500-799" + range3 = "bytes=-500" + range4 = "bytes=9500-" + ans1 = Just (0,400) + ans2 = Just (500,300) + ans3 = Just (9500,500) + ans4 = Just (9500,500) + +---------------------------------------------------------------- + +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.statusServerError + 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.statusNotFound + 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 fkLastModified hdr + Response sc _ _ <- sendGET url [("If-Modified-Since", lm)] + sc @?= H.statusNotModified + 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 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 hd BL.empty) +httpHandler _ = error "handler" 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.5.1 +Version: 0.5.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -7,11 +7,12 @@ Synopsis: File/CGI/Rev Proxy App of WAI Description: This WAI application handles static files, executes CGI scripts, and reverse proxy. -Homepage: http://www.mew.org/~kazu/ +Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Web, Yesod -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple -library + +Library if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else @@ -29,16 +30,39 @@ Network.Wai.Application.Classic.RevProxy Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types - Build-Depends: base >= 4 && < 5, process, - network, transformers, - filepath, directory, unix, - containers, attoparsec >= 0.10.0.0, - wai >= 1.1, conduit >= 0.2, - bytestring, blaze-builder, - wai-app-static >= 0.3, http-types, http-date, - case-insensitive, static-hash, - wai-logger, wai-logger-prefork, - http-conduit, lifted-base, attoparsec-conduit + Build-Depends: base >= 4 && < 5 + , alternative-io + , attoparsec >= 0.10.0.0 + , attoparsec-conduit + , blaze-builder + , bytestring + , case-insensitive + , conduit >= 0.2 + , containers + , directory + , filepath + , http-conduit + , http-date + , http-types + , lifted-base + , network + , process + , static-hash + , transformers + , unix + , wai >= 1.1 + , wai-app-static >= 0.3 + , wai-logger + +Test-Suite test + Main-Is: Test.hs + Type: exitcode-stdio-1.0 + Build-Depends: base >= 4 && < 5 + , HUnit + , test-framework-doctest + , test-framework-hunit + , test-framework-th-prime + Source-Repository head Type: git - Location: https://github.com/kazu-yamamoto/wai-app-file-cgi + Location: git clone git://github.com/kazu-yamamoto/wai-app-file-cgi