diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- WAI (Web Application Interface) Application for static files and CGI. module Network.Wai.Application.Classic ( 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 @@ -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) diff --git a/Network/Wai/Application/Classic/Conduit.hs b/Network/Wai/Application/Classic/Conduit.hs --- a/Network/Wai/Application/Classic/Conduit.hs +++ b/Network/Wai/Application/Classic/Conduit.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Def.hs b/Network/Wai/Application/Classic/Def.hs --- a/Network/Wai/Application/Classic/Def.hs +++ b/Network/Wai/Application/Classic/Def.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/EventSource.hs b/Network/Wai/Application/Classic/EventSource.hs --- a/Network/Wai/Application/Classic/EventSource.hs +++ b/Network/Wai/Application/Classic/EventSource.hs @@ -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 diff --git a/Network/Wai/Application/Classic/Field.hs b/Network/Wai/Application/Classic/Field.hs --- a/Network/Wai/Application/Classic/Field.hs +++ b/Network/Wai/Application/Classic/Field.hs @@ -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)] -- | 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,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 ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/FileInfo.hs b/Network/Wai/Application/Classic/FileInfo.hs --- a/Network/Wai/Application/Classic/FileInfo.hs +++ b/Network/Wai/Application/Classic/FileInfo.hs @@ -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")) 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 @@ -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 ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Redirect.hs b/Network/Wai/Application/Classic/Redirect.hs --- a/Network/Wai/Application/Classic/Redirect.hs +++ b/Network/Wai/Application/Classic/Redirect.hs @@ -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 diff --git a/Network/Wai/Application/Classic/RevProxy.hs b/Network/Wai/Application/Classic/RevProxy.hs --- a/Network/Wai/Application/Classic/RevProxy.hs +++ b/Network/Wai/Application/Classic/RevProxy.hs @@ -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 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where 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 @@ -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 diff --git a/test/ClassicSpec.hs b/test/ClassicSpec.hs --- a/test/ClassicSpec.hs +++ b/test/ClassicSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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] 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,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 @@ -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