wai-app-file-cgi 0.5.1 → 0.5.2
raw patch · 8 files changed
+377/−84 lines, 8 filesdep +HUnitdep +alternative-iodep +test-framework-doctestdep −wai-logger-prefork
Dependencies added: HUnit, alternative-io, test-framework-doctest, test-framework-hunit, test-framework-th-prime
Dependencies removed: wai-logger-prefork
Files
- Network/Wai/Application/Classic.hs +9/−3
- Network/Wai/Application/Classic/CGI.hs +30/−15
- Network/Wai/Application/Classic/File.hs +28/−39
- Network/Wai/Application/Classic/Path.hs +35/−1
- Network/Wai/Application/Classic/Status.hs +2/−9
- Network/Wai/Application/Classic/Types.hs +7/−2
- Test.hs +227/−0
- wai-app-file-cgi.cabal +39/−15
Network/Wai/Application/Classic.hs view
@@ -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
Network/Wai/Application/Classic/CGI.hs view
@@ -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'
Network/Wai/Application/Classic/File.hs view
@@ -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+ , "/"+ ] ----------------------------------------------------------------
Network/Wai/Application/Classic/Path.hs view
@@ -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)
Network/Wai/Application/Classic/Status.hs view
@@ -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" ----------------------------------------------------------------
Network/Wai/Application/Classic/Types.hs view
@@ -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'.
+ Test.hs view
@@ -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<html"++----------------------------------------------------------------++case_head :: Assertion+case_head = do+ Response sc _ _ <- sendHEAD url []+ sc @?= H.statusOK+ where+ url = "http://localhost:8080/"++----------------------------------------------------------------++case_head2 :: Assertion+case_head2 = do+ Response sc _ _ <- sendHEAD url []+ sc @?= H.statusNotFound+ where+ url = "http://localhost:8080/dummy"++----------------------------------------------------------------++case_head_ja :: Assertion+case_head_ja = do+ Response sc _ _ <- sendHEAD url [("Accept-Language", "ja, en;q=0.7")]+ sc @?= H.statusOK+ where+ url = "http://localhost:8080/ja/"++----------------------------------------------------------------++case_head_modified :: Assertion+case_head_modified = do+ Response _ hdr _ <- sendHEAD url []+ let Just lm = lookup fkLastModified hdr+ Response sc _ _ <- sendHEAD url [("If-Modified-Since", lm)]+ sc @?= H.statusNotModified+ where+ url = "http://localhost:8080/"++----------------------------------------------------------------++case_redirect :: Assertion+case_redirect = do+ rsp <- simpleHttp url+ ans <- BL.readFile "test/html/redirect/index.html"+ rsp @?= ans+ where+ url = "http://localhost:8080/redirect"++----------------------------------------------------------------+----------------------------------------------------------------++sendGET ::String -> 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"
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.5.1+Version: 0.5.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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