wai-app-file-cgi 3.2.2 → 3.2.3
raw patch · 17 files changed
+182/−157 lines, 17 filesdep −arraydep −http-datedep −transformersdep ~conduitPVP ok
version bump matches the API change (PVP)
Dependencies removed: array, http-date, transformers, unix, word8
Dependency ranges changed: conduit
API changes (from Hackage documentation)
Files
- CHANGELOG.md +22/−0
- Network/Wai/Application/Classic.hs +0/−2
- Network/Wai/Application/Classic/CGI.hs +39/−48
- Network/Wai/Application/Classic/Conduit.hs +0/−9
- Network/Wai/Application/Classic/Def.hs +4/−4
- Network/Wai/Application/Classic/EventSource.hs +0/−10
- Network/Wai/Application/Classic/Field.hs +2/−1
- Network/Wai/Application/Classic/File.hs +11/−8
- Network/Wai/Application/Classic/FileInfo.hs +1/−1
- Network/Wai/Application/Classic/Path.hs +8/−3
- Network/Wai/Application/Classic/Redirect.hs +2/−2
- Network/Wai/Application/Classic/RevProxy.hs +4/−16
- Network/Wai/Application/Classic/Status.hs +0/−1
- Network/Wai/Application/Classic/Types.hs +8/−10
- test/ClassicSpec.hs +45/−13
- test/Spec.hs +31/−11
- wai-app-file-cgi.cabal +5/−18
CHANGELOG.md view
@@ -1,5 +1,27 @@ # ChangeLog for wai-app-file-cgi +## 3.2.3++- Security: request headers containing `_` are not passed to CGI+ since they would collide with ones containing `-`+ (e.g. `X_Forwarded_For` vs `X-Forwarded-For`).+- Paths and CGI variables are converted with the file system+ encoding. Non-ASCII file names and header values work now.+- `cgiApp`:+ - CGI processes are reaped by this library. The program does+ not have to ignore SIGCHLD anymore. Ignoring it is still+ possible but a PID may be reused before it is terminated.+ - 404 is returned if the CGI program does not exist.+- `fileApp`:+ - `Vary: Accept-Language` is added to HTML responses.+ - `Allow:` is added to 405 responses.+- `redirectApp` keeps the query string.+- `revProxyApp` appends `Via:` to requests to the upstream.+- Dropping support for conduit < 1.3 and removing unused+ dependencies.+- The test suite works from the tarball. CGI scripts for tests+ are made executable since `cabal sdist` drops the bit.+ ## 3.2.2 - Security: request paths containing `..` segments are rejected
Network/Wai/Application/Classic.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- | -- WAI (Web Application Interface) Application for static files and CGI. module Network.Wai.Application.Classic (
Network/Wai/Application/Classic/CGI.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Network.Wai.Application.Classic.CGI ( cgiApp ) where import qualified Control.Exception as E (SomeException, SomeAsyncException, IOException, try, catch, bracket, fromException, throwIO)-import Control.Concurrent (forkFinally, killThread, newEmptyMVar, putMVar, takeMVar)-import Control.Monad (mplus)+import Control.Concurrent (forkFinally, forkIO, killThread, newEmptyMVar, putMVar, takeMVar)+import Control.Monad (mplus, void) import Data.ByteString (ByteString) import Data.CaseInsensitive (foldedCase) import Data.Char (toUpper) import Data.List (nub)-import qualified Data.ByteString.Char8 as BS (dropWhile, intercalate, pack, readInt, unpack, tail)+import qualified Data.ByteString.Char8 as BS (dropWhile, elem, intercalate, pack, readInt, unpack, tail) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL@@ -25,6 +25,7 @@ import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types+import System.Directory (doesFileExist) import System.Environment import System.IO import System.Process@@ -44,21 +45,33 @@ {-| Handle any methods for CGI. -The program to link this library must ignore SIGCHLD as follows:--> installHandler sigCHLD Ignore Nothing+CGI processes are reaped by this library. The program to link this+library should not ignore SIGCHLD. Otherwise, the PID of a finished+CGI process may be reused by another process before it is terminated. -} cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp cspec spec cgii req respond | hasDotDotSegment (rawPathInfo req) = respond $ responseLBS badRequest400 textPlainHeader "Bad Request\r\n"- | otherwise = E.bracket setup teardown cgi+ | otherwise = do+ exist <- doesFileExist prog+ if exist+ then E.bracket setup teardown cgi+ else respond $ responseLBS notFound404 textPlainHeader "Not Found\r\n" where- setup = execProcess cspec spec cgii req+ cgiPath@(prog,_,_) =+ pathinfoToCGI (cgiSrc cgii)+ (cgiDst cgii)+ (rawPathInfo req)+ (indexCgi spec)+ setup = execProcess cspec cgiPath req+ -- An unreaped process keeps its PID, so SIGTERM cannot hit+ -- another process. Reaping may block, hence in another thread. teardown (rhdl,whdl,pid) = do terminateProcess pid -- SIGTERM hClose rhdl hClose whdl+ void $ forkIO $ void (waitForProcess pid) `E.catch` ignore -- The body is written in another thread so that the CGI output -- can be read concurrently. Otherwise, both pipes may fill up. cgi (rhdl,whdl,_) = E.bracket (forkWriter whdl) stopWriter $ \_ ->@@ -77,11 +90,7 @@ type TRYPATH = Either E.IOException String toCGI :: Handle -> Request -> IO ()-#if MIN_VERSION_conduit(1,3,0) toCGI whdl req = runConduit (sourceRequestBody req .| CB.sinkHandle whdl)-#else-toCGI whdl req = sourceRequestBody req $$ CB.sinkHandle whdl-#endif fromCGI :: Handle -> IO Response fromCGI rhdl = do@@ -115,8 +124,8 @@ ---------------------------------------------------------------- -execProcess :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle)-execProcess cspec spec cgii req = do+execProcess :: ClassicAppSpec -> (FilePath, String, String) -> Request -> IO (Handle, Handle, ProcessHandle)+execProcess cspec (prog, scriptName, pathinfo) req = do let naddr = showSockAddr . remoteHost $ req epath <- E.try (getEnv "PATH") :: IO TRYPATH (Just whdl,Just rhdl,_,pid) <- createProcess $ proSpec naddr epath@@ -124,36 +133,13 @@ hSetEncoding whdl latin1 return (rhdl, whdl, pid) where- proSpec naddr epath = CreateProcess {- cmdspec = RawCommand prog []- , cwd = Nothing- , env = Just $ makeEnv req naddr prog scriptName pathinfo (softwareName cspec) epath+ proSpec naddr epath = (proc prog []) {+ env = Just $ makeEnv req naddr prog scriptName pathinfo (softwareName cspec) epath , std_in = CreatePipe , std_out = CreatePipe- , std_err = Inherit , close_fds = True-#if __GLASGOW_HASKELL__ >= 702 , create_group = True-#endif-#if __GLASGOW_HASKELL__ >= 707- , delegate_ctlc = False-#endif-#if __GLASGOW_HASKELL__ >= 800- , detach_console = False- , create_new_console = False- , new_session = False- , child_group = Nothing- , child_user = Nothing-#endif-#if __GLASGOW_HASKELL__ >= 802- , use_process_jobs = False-#endif }- (prog, scriptName, pathinfo) =- pathinfoToCGI (cgiSrc cgii)- (cgiDst cgii)- (rawPathInfo req)- (indexCgi spec) makeEnv :: Request -> String -> FilePath -> String -> String -> ByteString -> TRYPATH -> ENVVARS@@ -164,12 +150,12 @@ ("GATEWAY_INTERFACE", gatewayInterface) , ("SCRIPT_NAME", scriptName) , ("SCRIPT_FILENAME", prog)- , ("REQUEST_METHOD", BS.unpack . requestMethod $ req)- , ("SERVER_NAME", BS.unpack host)- , ("SERVER_PORT", BS.unpack port)+ , ("REQUEST_METHOD", pathString . requestMethod $ req)+ , ("SERVER_NAME", pathString host)+ , ("SERVER_PORT", pathString port) , ("REMOTE_ADDR", naddr) , ("SERVER_PROTOCOL", show . httpVersion $ req)- , ("SERVER_SOFTWARE", BS.unpack sname)+ , ("SERVER_SOFTWARE", pathString sname) , ("PATH_INFO", pathinfo) , ("QUERY_STRING", query req) ]@@ -182,7 +168,7 @@ httpEnv = httpHeadersToEnv headers addPath (Left _) ev = ev addPath (Right path) ev = ("PATH", path) : ev- query = BS.unpack . safeTail . rawQueryString+ query = pathString . safeTail . rawQueryString where safeTail "" = "" safeTail bs = BS.tail bs@@ -190,7 +176,7 @@ addEnv :: String -> Maybe ByteString -> ENVVARS -> ENVVARS addEnv _ Nothing envs = envs-addEnv key (Just val) envs = (key,BS.unpack val) : envs+addEnv key (Just val) envs = (key,pathString val) : envs remotePort :: SockAddr -> Maybe ByteString remotePort (SockAddrInet p _) = Just $ BS.pack $ show p@@ -200,17 +186,22 @@ {-| Converting request headers to HTTP_* variables. Values of the same header are joined.+ Headers containing '_' are dropped since they would collide with+ ones containing '-' (e.g. X_Forwarded_For vs X-Forwarded-For). >>> httpHeadersToEnv [("User-Agent","foo"),("Accept","a"),("accept","b"),("Proxy","x"),("Authorization","y"),("Content-Type","z")] [("HTTP_USER_AGENT","foo"),("HTTP_ACCEPT","a, b")]+>>> httpHeadersToEnv [("X-Forwarded-For","192.0.2.1"),("X_Forwarded_For","192.0.2.2")]+[("HTTP_X_FORWARDED_FOR","192.0.2.1")] -} httpHeadersToEnv :: RequestHeaders -> ENVVARS httpHeadersToEnv hdrs = map toEnv $ nub $ map fst relayed where- relayed = filter (\(k,_) -> k `notElem` excluded) hdrs+ relayed = filter (\(k,_) -> k `notElem` excluded && not (hasUnderscore k)) hdrs+ hasUnderscore = BS.elem '_' . foldedCase -- "Proxy" is excluded to prevent httpoxy. excluded = [hContentType, hContentLength, hAuthorization, hProxyAuthorization, "proxy"]- toEnv k = (envName k, BS.unpack $ BS.intercalate (sep k) [v | (k',v) <- relayed, k' == k])+ toEnv k = (envName k, pathString $ BS.intercalate (sep k) [v | (k',v) <- relayed, k' == k]) sep k | k == hCookie = "; " | otherwise = ", " envName k = "HTTP_" ++ map conv (BS.unpack $ foldedCase k)
Network/Wai/Application/Classic/Conduit.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Conduit (@@ -26,19 +25,11 @@ ---------------------------------------------------------------- -#if MIN_VERSION_conduit(1,3,0) toResponseSource :: SealedConduitT () ByteString IO () -> IO (ConduitT () (Flush Builder) IO ()) toResponseSource rsrc = do let src = unsealConduitT rsrc return $ src .| CL.map (Chunk . byteStringToBuilder)-#else-toResponseSource :: ResumableSource IO ByteString- -> IO (Source IO (Flush Builder))-toResponseSource rsrc = do- (src,_) <- unwrapResumable rsrc- return $ src $= CL.map (Chunk . byteStringToBuilder)-#endif ----------------------------------------------------------------
Network/Wai/Application/Classic/Def.hs view
@@ -6,7 +6,7 @@ import Network.Wai.Application.Classic.Types -- |--- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\".+-- Default value for t'ClassicAppSpec'. 'softwareName' is \"Classic\". 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". defaultClassicAppSpec :: ClassicAppSpec defaultClassicAppSpec = ClassicAppSpec@@ -22,11 +22,11 @@ defaultFileAppSpec = FileAppSpec { indexFile = "index.html"- , isHTML = defaultIsHTml+ , isHTML = defaultIsHTML } -defaultIsHTml :: Path -> Bool-defaultIsHTml file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file+defaultIsHTML :: Path -> Bool+defaultIsHTML file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file ----------------------------------------------------------------
Network/Wai/Application/Classic/EventSource.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.EventSource (@@ -50,11 +49,7 @@ in xs : go ys 0 | otherwise = [bs] -#if MIN_VERSION_conduit(1,3,0) eventSourceConduit :: ConduitT ByteString (Flush Builder) IO ()-#else-eventSourceConduit :: Conduit ByteString IO (Flush Builder)-#endif eventSourceConduit = CL.concatMapAccum f "" where f input rest = (last xs, concatMap addFlush $ init xs)@@ -63,10 +58,5 @@ xs = splitDoubleLineBreak (rest `BS.append` input) -- insert Flush if exists a double line-break-#if MIN_VERSION_conduit(1,3,0) bodyToEventSource :: H.BodyReader -> ConduitT () (Flush Builder) IO () bodyToEventSource br = HC.bodyReaderSource br .| eventSourceConduit-#else-bodyToEventSource :: H.BodyReader -> Source IO (Flush Builder)-bodyToEventSource br = HC.bodyReaderSource br $= eventSourceConduit-#endif
Network/Wai/Application/Classic/Field.hs view
@@ -73,9 +73,10 @@ [] -> (key, val) : hdr vs -> (key, BS.intercalate ", " (vs ++ [val])) : filter ((/= key) . fst) hdr +-- | HTML files are selected by Accept-Language. newHeader :: Bool -> ByteString -> ResponseHeaders newHeader ishtml file- | ishtml = textHtmlHeader+ | ishtml = (hVary, "Accept-Language") : textHtmlHeader | otherwise = [(hContentType, mimeType file)] -- |
Network/Wai/Application/Classic/File.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.File (@@ -42,19 +41,19 @@ -- | -- Handle GET and HEAD for a static file. ----- If 'pathInfo' ends with \'/\', 'indexFile' is automatically--- added. In this case, "Acceptable-Language:" is also handled. Suppose+-- If 'rawPathInfo' ends with \'/\', 'indexFile' is automatically+-- added. In this case, \"Accept-Language:\" is also handled. Suppose -- 'indexFile' is "index.html" and if the value is "ja,en", then -- \"index.html.ja\", \"index.html.en\", and \"index.html\" are tried to be -- opened in order. ----- If 'pathInfo' does not end with \'/\' and a corresponding index file+-- If 'rawPathInfo' does not end with \'/\' and a corresponding index file -- exist, redirection is specified in HTTP response. -- -- Directory contents are NOT automatically listed. To list directory -- contents, an index file must be created beforehand. ----- The following HTTP headers are handled: Acceptable-Language:,+-- The following HTTP headers are handled: Accept-Language:, -- If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:. fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req respond = do@@ -76,7 +75,11 @@ ishtml = isHTML spec file rfile = redirectPath spec path langs = langSuffixes $ requestHeaders req- noBody st = return $ responseLBS st [] ""+ -- 405 must contain Allow:.+ extra st+ | st == methodNotAllowed405 = [(hAllow, "GET, HEAD")]+ | otherwise = []+ noBody st = return $ responseLBS st (extra st) "" bodyStatus st = getStatusInfo cspec req langs st >>= statusBody st@@ -84,13 +87,13 @@ statusBody st (StatusByteString bd) = return $ responseLBS st hdr bd where- hdr = textPlainHeader+ hdr = extra st ++ textPlainHeader statusBody st (StatusFile afile len) = return $ ResponseFile st hdr fl mfp where mfp = Just (FilePart 0 len len) fl = pathString afile- hdr = textHtmlHeader+ hdr = extra st ++ textHtmlHeader ----------------------------------------------------------------
Network/Wai/Application/Classic/FileInfo.hs view
@@ -49,7 +49,7 @@ -- | ----- It matters to 'pathinfoToFilePath' whether the 'FileRoute' has trailing slashes+-- It matters to 'pathinfoToFilePath' whether the t'FileRoute' has trailing slashes -- which also influences 'addIndex': -- -- >>> addIndex defaultFileAppSpec (pathinfoToFilePath (mkReq "/exact/match.html") (FileRoute "/exact/match.html" "/some/file.html"))
Network/Wai/Application/Classic/Path.hs view
@@ -17,9 +17,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as B8 import Data.String import Data.Word+import qualified GHC.Foreign as GHC+import GHC.IO.Encoding (getFileSystemEncoding)+import System.IO.Unsafe (unsafeDupablePerformIO) -- $setup -- >>> :set -XOverloadedStrings@@ -29,9 +31,12 @@ -- | File path. type Path = ByteString +-- | Converting to 'String' with the file system encoding so that+-- the original bytes are used when it is passed to the OS. pathString :: Path -> String-pathString = B8.unpack-{-# INLINE pathString #-}+pathString bs = unsafeDupablePerformIO $ do+ enc <- getFileSystemEncoding+ BS.useAsCStringLen bs $ GHC.peekCStringLen enc ----------------------------------------------------------------
Network/Wai/Application/Classic/Redirect.hs view
@@ -4,7 +4,7 @@ redirectApp, ) where -import Data.ByteString.Char8+import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field@@ -20,6 +20,6 @@ dst = redirectDst route -- Scheme must not be included because of no way to tell -- http or https.- rurl = "//" `append` (dst </> (path <\> src))+ rurl = BS.concat ["//", dst </> (path <\> src), rawQueryString req] hdr = locationHeader rurl status = movedPermanently301
Network/Wai/Application/Classic/RevProxy.hs view
@@ -1,11 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.RevProxy (revProxyApp) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class (liftIO)@@ -53,7 +49,7 @@ then E.throwIO (e :: H.HttpException) else respond $ responseLBS badGateway502 textPlainHeader "Bad Gateway\r\n" - httpClientRequest = reqToHReq req route+ httpClientRequest = reqToHReq cspec req route mgr = revProxyManager spec fixHeader = addVia cspec req . filterHeaders @@ -88,13 +84,13 @@ ---------------------------------------------------------------- -reqToHReq :: Request -> RevProxyRoute -> H.Request-reqToHReq req route =+reqToHReq :: ClassicAppSpec -> Request -> RevProxyRoute -> H.Request+reqToHReq cspec req route = H.defaultRequest { H.host = revProxyDomain route , H.port = revProxyPort route , H.secure = False -- FIXME: upstream is HTTP only- , H.requestHeaders = addForwardedFor req $ filterHeaders hdr+ , H.requestHeaders = addVia cspec req $ addForwardedFor req $ filterHeaders hdr , H.path = path' , H.queryString = dropQuestion query , H.requestBody = bodyToHBody len body@@ -124,19 +120,11 @@ ---------------------------------------------------------------- -#if MIN_VERSION_conduit(1,3,0) toSource :: Maybe ByteString -> H.BodyReader -> ConduitT () (Flush Builder) IO ()-#else-toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder)-#endif toSource (Just "text/event-stream") = bodyToEventSource toSource _ = bodyToSource -#if MIN_VERSION_conduit(1,3,0) bodyToSource :: H.BodyReader -> ConduitT () (Flush Builder) IO ()-#else-bodyToSource :: H.BodyReader -> Source IO (Flush Builder)-#endif bodyToSource br = loop where loop = do
Network/Wai/Application/Classic/Status.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where
Network/Wai/Application/Classic/Types.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Network.Wai.Application.Classic.Types where import Data.ByteString (ByteString)@@ -17,7 +15,7 @@ } data StatusInfo- = -- | HTTP status body is created from 'LB.ByteString'.+ = -- | HTTP status body is created from 'BL.ByteString'. StatusByteString BL.ByteString | -- | HTTP status body is created from 'FilePath'. StatusFile Path Integer@@ -34,9 +32,9 @@ -- ^ Whether this is an HTML or not. } --- | 'FileRoute' describes the relationship between Paths requested via HTTP+-- | t'FileRoute' describes the relationship between Paths requested via HTTP -- and paths to serve on disk. Specifically, it maps a /single/ path--- prefix to a destination path, so the 'FileRoute' needs to be applicable+-- prefix to a destination path, so the t'FileRoute' needs to be applicable -- to the current request, -- e.g. @FileRoute "\/static\/" "\/var\/www\/static\/"@ will yield a 404 if -- @"/page.html"@ is requested.@@ -53,13 +51,13 @@ -- * If 'fileSrc' and 'fileDst' lack a trailing slash, they are -- assumed to be files. This is supported since 3.2.0. ----- If the path type inferrable from 'FileRoute' does not match+-- If the path type inferrable from t'FileRoute' does not match -- the type of the destination path on disk, routes will not -- resolve correctly. If the inferrable type doesn't match -- between 'fileSrc' and 'fileDst', routing may also misbehave. data FileRoute = FileRoute { fileSrc :: Path- -- ^ Path (prefix) to be matched to 'rawPathInfo'.+ -- ^ Path (prefix) to be matched to 'Network.Wai.rawPathInfo'. , fileDst :: Path -- ^ Path to the target directory or file. }@@ -69,7 +67,7 @@ data RedirectRoute = RedirectRoute { redirectSrc :: Path- -- ^ Path prefix to be matched to 'rawPathInfo'.+ -- ^ Path prefix to be matched to 'Network.Wai.rawPathInfo'. , redirectDst :: Path -- ^ Path prefix to an actual file system. }@@ -85,7 +83,7 @@ data CgiRoute = CgiRoute { cgiSrc :: Path- -- ^ Path prefix to be matched to 'rawPathInfo'.+ -- ^ Path prefix to be matched to 'Network.Wai.rawPathInfo'. , cgiDst :: Path -- ^ Path prefix to an actual file system. }@@ -100,7 +98,7 @@ data RevProxyRoute = RevProxyRoute { revProxySrc :: Path- -- ^ Path prefix to be matched to 'rawPathInfo'.+ -- ^ Path prefix to be matched to 'Network.Wai.rawPathInfo'. , revProxyDst :: Path -- ^ Destination path prefix. , revProxyDomain :: ByteString
test/ClassicSpec.hs view
@@ -1,14 +1,13 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module ClassicSpec where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif+import Control.Exception (bracket_) import Data.List (isPrefixOf)+import qualified Network.HTTP.Client as H import Network.HTTP import Network.Stream+import System.Directory (removeFile) import System.IO import Test.Hspec @@ -40,14 +39,19 @@ rspCode rsp `shouldBe` (3, 0, 2) lookupHeader HdrLocation (rspHeaders rsp) `shouldBe` Just "http://example.com/"- it "passes request headers as HTTP_* except Proxy" $ do+ it "passes request headers as HTTP_* except Proxy and ones with _" $ do let url = "http://127.0.0.1:2345/cgi-bin/http-env" hdr = [ Header (HdrCustom "X-Foo") "foo"+ , Header (HdrCustom "X_Foo") "evil" , Header (HdrCustom "Proxy") "http://evil.example/" ] bdy <- rspBody <$> sendGETwH url hdr lines bdy `shouldBe` ["HTTP_X_FOO: foo", "HTTP_PROXY: ", "REMOTE_PORT: yes"]+ it "passes non-ASCII header values as is" $ do+ let url = "http://127.0.0.1:2345/cgi-bin/http-env"+ bdy <- rspBody <$> sendGETwH url [Header (HdrCustom "X-Foo") "\xe6\x97\xa5"]+ take 1 (lines bdy) `shouldBe` ["HTTP_X_FOO: \xe6\x97\xa5"] it "accepts HEAD" $ do let url = "http://127.0.0.1:2345/cgi-bin/" rsp <- sendHEAD url@@ -57,6 +61,10 @@ let url = "http://127.0.0.1:2345/cgi-bin/broken" sc <- rspCode <$> sendPOST url "foo bar.\nbaz!\n" sc `shouldBe` (5, 0, 0)+ it "returns 404 if the CGI does not exist" $ do+ let url = "http://127.0.0.1:2345/cgi-bin/nonexistent"+ sc <- rspCode <$> sendGET url+ sc `shouldBe` (4, 0, 4) it "returns 400 if the path contains .." $ do let url = "http://127.0.0.1:2345/cgi-bin/../cgi-bin/index.cgi" sc <- rspCode <$> sendGET url@@ -72,6 +80,15 @@ bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/no_extension" bdy `shouldBe` ans+ it "serves files with non-ASCII names" $ do+ -- The path is sent in raw UTF-8 as decoded by mighttpd2.+ let file = "test/html/\26085\26412.txt"+ mgr <- H.newManager H.defaultManagerSettings+ hreq <- H.parseRequest "http://127.0.0.1:2345/"+ let hreq' = hreq{H.path = "/\xe6\x97\xa5\xe6\x9c\xac.txt"}+ bdy <- bracket_ (writeFile file "hello\n") (removeFile file) $+ H.responseBody <$> H.httpLbs hreq' mgr+ bdy `shouldBe` "hello\n" it "returns 404 if not exist" $ do let url = "http://127.0.0.1:2345/dummy" sc <- rspCode <$> sendGET url@@ -85,6 +102,10 @@ bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"] ans <- readFileAscii "test/html/ja/index.html.ja" bdy `shouldBe` ans+ it "returns Vary: Accept-Language for HTML" $ do+ let url = "http://127.0.0.1:2345/ja/"+ rsp <- sendGETwH url [Header HdrAcceptLanguage "ja"]+ lookupHeader HdrVary (rspHeaders rsp) `shouldBe` Just "Accept-Language" it "returns English HTML even if language is specified" $ do let url = "http://127.0.0.1:2345/" bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"]@@ -93,7 +114,7 @@ it "returns 304 if not changed" $ do let url = "http://127.0.0.1:2345/" hdr <- rspHeaders <$> sendGET url- let Just lm = lookupHeader HdrLastModified hdr+ lm <- maybe (fail "no Last-Modified") return $ lookupHeader HdrLastModified hdr sc <- rspCode <$> sendGETwH url [Header HdrIfModifiedSince lm] sc `shouldBe` (3, 0, 4) it "can handle partial request" $ do@@ -105,6 +126,11 @@ let url = "http://127.0.0.1:2345/" sc <- rspCode <$> sendHEAD url sc `shouldBe` (2, 0, 0)+ it "returns 405 with Allow for other methods" $ do+ let url = "http://127.0.0.1:2345/"+ rsp <- unResult $ simpleHTTP $ (getRequest url){rqMethod = OPTIONS}+ rspCode rsp `shouldBe` (4, 0, 5)+ lookupHeader HdrAllow (rspHeaders rsp) `shouldBe` Just "GET, HEAD" it "returns 404 for HEAD if not exist" $ do let url = "http://127.0.0.1:2345/dummy" sc <- rspCode <$> sendHEAD url@@ -116,17 +142,15 @@ it "returns 304 for HEAD if not modified" $ do let url = "http://127.0.0.1:2345/" hdr <- rspHeaders <$> sendHEAD url- let Just lm = lookupHeader HdrLastModified hdr+ lm <- maybe (fail "no Last-Modified") return $ lookupHeader HdrLastModified hdr sc <- rspCode <$> sendHEADwH url [Header HdrIfModifiedSince lm] sc `shouldBe` (3, 0, 4) it "redirects to dir/ if trailing slash is missing" $ do let url = "http://127.0.0.1:2345/redirect" rsp <- sendGET url- let sc = rspCode rsp- hdr = rspHeaders rsp- Just lm = lookupHeader HdrLocation hdr- sc `shouldBe` (3, 0, 1)- lm `shouldBe` "//127.0.0.1:2345/redirect/"+ rspCode rsp `shouldBe` (3, 0, 1)+ lookupHeader HdrLocation (rspHeaders rsp)+ `shouldBe` Just "//127.0.0.1:2345/redirect/" it "keeps the query string when redirecting to dir/" $ do let url = "http://127.0.0.1:2345/redirect?foo=bar" rsp <- sendGET url@@ -137,12 +161,19 @@ bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/index.html" bdy `shouldBe` ans+ describe "redirectApp" $ do+ it "redirects keeping the query string" $ do+ let url = "http://127.0.0.1:2345/redirect-app/foo?bar=baz"+ rsp <- sendGET url+ rspCode rsp `shouldBe` (3, 0, 1)+ lookupHeader HdrLocation (rspHeaders rsp)+ `shouldBe` Just "//example.com/new/foo?bar=baz" describe "revProxyApp" $ do it "returns 502 if the upstream is not available" $ do let url = "http://127.0.0.1:2345/revproxy/" sc <- rspCode <$> sendGET url sc `shouldBe` (5, 0, 2)- it "removes hop-by-hop headers and appends X-Forwarded-For" $ do+ it "removes hop-by-hop headers and appends X-Forwarded-For and Via" $ do let url = "http://127.0.0.1:2345/upstream/" hdr = [ Header HdrProxyAuthorization "secret"@@ -152,6 +183,7 @@ let ls = lines $ rspBody rsp rhdr = rspHeaders rsp ls `shouldContain` ["x-forwarded-for: 192.0.2.1, 127.0.0.1"]+ ls `shouldContain` ["via: 1.1 127.0.0.1:2345 (ClassicTester)"] filter (isPrefixOf "proxy-authorization") ls `shouldBe` [] lookupHeader (HdrCustom "X-Up") rhdr `shouldBe` Nothing lookupHeader (HdrCustom "Keep-Alive") rhdr `shouldBe` Nothing
test/Spec.hs view
@@ -15,38 +15,55 @@ import Network.Wai.Handler.Warp import System.Directory import System.FilePath-import System.Posix import Test.Hspec main :: IO () main = do- void $ installHandler sigCHLD Ignore Nothing+ -- "cabal sdist" drops the executable bit.+ scripts <- listDirectory "test/cgi-bin"+ forM_ scripts $ \f -> do+ let file = "test/cgi-bin" </> f+ p <- getPermissions file+ setPermissions file $ setOwnerExecutable True p mgr <- H.newManager H.defaultManagerSettings- void $ forkIO $ testServer mgr- void $ forkIO upstreamServer- threadDelay 100000+ ready1 <- newEmptyMVar+ ready2 <- newEmptyMVar+ void $ forkIO $ testServer (putMVar ready1 ()) mgr+ void $ forkIO $ upstreamServer (putMVar ready2 ())+ takeMVar ready1+ takeMVar ready2 hspec spec -testServer :: H.Manager -> IO ()-testServer mgr = do+testServer :: IO () -> H.Manager -> IO ()+testServer ready mgr = do dir <- getCurrentDirectory runSettings settings $ testApp mgr dir where- settings = setPort 2345 $ setHost "127.0.0.1" defaultSettings+ settings =+ setBeforeMainLoop ready $+ setPort 2345 $+ setHost "127.0.0.1" defaultSettings testApp :: H.Manager -> FilePath -> Application testApp mgr dir req | revproxy = revProxyApp appSpec (RevProxyAppSpec mgr) revProxyRoute req | upstream = revProxyApp appSpec (RevProxyAppSpec mgr) upstreamRoute req+ | redirect = redirectApp appSpec redirectRoute req | cgi = cgiApp appSpec defaultCgiAppSpec cgiRoute req | exact = fileApp appSpec defaultFileAppSpec exactRoute req | otherwise = fileApp appSpec defaultFileAppSpec fileRoute req where revproxy = "/revproxy/" `BS.isPrefixOf` rawPathInfo req upstream = "/upstream/" `BS.isPrefixOf` rawPathInfo req+ redirect = "/redirect-app/" `BS.isPrefixOf` rawPathInfo req cgi = "/cgi-bin/" `BS.isPrefixOf` rawPathInfo req exact = "/exact-route.html" `BS.isPrefixOf` rawPathInfo req appSpec = defaultClassicAppSpec{softwareName = "ClassicTester"}+ redirectRoute =+ RedirectRoute+ { redirectSrc = "/redirect-app/"+ , redirectDst = "example.com/new/"+ } cgiRoute = CgiRoute { cgiSrc = "/cgi-bin/"@@ -79,10 +96,13 @@ } -- | Echoing request headers with hop-by-hop response headers.-upstreamServer :: IO ()-upstreamServer = runSettings settings $ \req respond ->+upstreamServer :: IO () -> IO ()+upstreamServer ready = runSettings settings $ \req respond -> respond $ responseLBS ok200 hdr $ BL.unlines $ map toLine $ requestHeaders req where- settings = setPort 2346 $ setHost "127.0.0.1" defaultSettings+ settings =+ setBeforeMainLoop ready $+ setPort 2346 $+ setHost "127.0.0.1" defaultSettings hdr = [("Connection", "X-Up"), ("X-Up", "1"), ("Keep-Alive", "timeout=5")] toLine (k, v) = BL.fromStrict $ BS.concat [foldedCase k, ": ", v]
wai-app-file-cgi.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: wai-app-file-cgi-version: 3.2.2+version: 3.2.3 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -54,21 +54,19 @@ Network.Wai.Application.Classic.RevProxy default-language: Haskell2010+ default-extensions: Strict StrictData ghc-options: -Wall build-depends: base >=4.9 && <5,- array, attoparsec >=0.10.0.0, bytestring, case-insensitive,- conduit >=1.1,+ conduit >=1.3, conduit-extra, containers, directory,- filepath, http-client >=0.5, http-conduit >=2.1,- http-date, http-types >=0.12.5, mime-types, network,@@ -76,15 +74,9 @@ sockaddr, static-hash, text,- transformers,- unix, wai >=3.2 && <3.3, wai-conduit,- warp >=3.4 && <3.5,- word8-- if impl(ghc >=8)- default-extensions: Strict StrictData+ warp >=3.4 && <3.5 test-suite spec type: exitcode-stdio-1.0@@ -92,23 +84,18 @@ hs-source-dirs: test other-modules: ClassicSpec default-language: Haskell2010+ default-extensions: Strict StrictData ghc-options: -threaded -Wall build-depends: base >=4.9 && <5, bytestring, case-insensitive,- conduit >=1.1,- conduit-extra, directory, filepath, hspec >=1.3, http-client, http-types,- unix, wai >=3.2 && <3.3, wai-app-file-cgi, warp >=3.4 && <3.5, HTTP-- if impl(ghc >=8)- default-extensions: Strict StrictData