diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,38 @@ # ChangeLog for wai-app-file-cgi +## 3.2.2 + +- Security: request paths containing `..` segments are rejected + with 400 in `fileApp` and `cgiApp`. Previously, files outside + `fileDst` could be served. +- Security: languages in Accept-Language are used as file suffixes + only if they consist of alphanumerics and `-`. Languages with + `q=0` and `*` are ignored. +- `cgiApp`: + - Fixing a deadlock when a CGI script writes a large output + while reading a large request body. + - Any methods are passed to CGI scripts. 405 is not returned + anymore. + - Request headers are passed as `HTTP_*` except `Proxy` + (httpoxy), `Authorization` and `Proxy-Authorization`. + `SCRIPT_FILENAME`, `REMOTE_PORT` and `HTTPS` are also passed. + - Responses with `Location:` but without `Content-Type:` are + returned as 302 instead of 500. + - The status code is not duplicated in the reason phrase. + - The index CGI is used if the program name is empty + (e.g. `/cgi-bin`). +- `fileApp`: + - MIME types are determined from the file name only, trying the + longest extension first, case-insensitively. + - The query string is kept when redirecting to a directory. +- `revProxyApp`: + - 502 is returned if the upstream is not available. + - Hop-by-hop headers and headers listed in `Connection:` are + removed. + - `X-Forwarded-For:` and `Via:` are appended to existing ones. +- `hostPort` handles IPv6 literals such as `[::1]:8080` and uses 443 + as the default port for secure connections. + ## 3.2.0 - `FileRoute`s now allow routing a requested path directly to a file 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 @@ -4,15 +4,20 @@ cgiApp ) where -import qualified Control.Exception as E (SomeException, IOException, try, catch, bracket) -import Control.Monad (when, (<=<)) +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 Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS (readInt, unpack, tail) +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 Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Network.HTTP.Types import Network.SockAddr +import Network.Socket (SockAddr (..)) import Network.Wai import Network.Wai.Conduit import Network.Wai.Application.Classic.Conduit @@ -37,32 +42,35 @@ ---------------------------------------------------------------- {-| - Handle GET and POST for CGI. + Handle any methods for CGI. The program to link this library must ignore SIGCHLD as follows: > installHandler sigCHLD Ignore Nothing -} cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application -cgiApp cspec spec cgii req respond = case method of - Right GET -> cgiApp' False cspec spec cgii req respond - Right POST -> cgiApp' True cspec spec cgii req respond - _ -> respond $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx - where - method = parseMethod $ requestMethod req - -cgiApp' :: Bool -> ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application -cgiApp' body cspec spec cgii req respond = E.bracket setup teardown (respond <=< cgi) +cgiApp cspec spec cgii req respond + | hasDotDotSegment (rawPathInfo req) = + respond $ responseLBS badRequest400 textPlainHeader "Bad Request\r\n" + | otherwise = E.bracket setup teardown cgi where setup = execProcess cspec spec cgii req teardown (rhdl,whdl,pid) = do terminateProcess pid -- SIGTERM hClose rhdl hClose whdl - cgi (rhdl,whdl,_) = do - when body $ toCGI whdl req - hClose whdl -- telling EOF - fromCGI rhdl + -- 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 $ \_ -> + respond =<< fromCGI rhdl + forkWriter whdl = do + done <- newEmptyMVar + tid <- forkFinally (toCGI whdl req) $ \_ -> do + hClose whdl `E.catch` ignore -- telling EOF + putMVar done () + return (tid, done) + stopWriter (tid, done) = killThread tid >> takeMVar done + ignore (_ :: E.IOException) = return () ---------------------------------------------------------------- @@ -85,14 +93,21 @@ | otherwise = CL.sourceNull return $ responseSource st hdr src where - check hs = lookup hContentType hs >> case lookup hStatus hs of - Nothing -> Just (ok200, hs) + -- A redirect response may lack Content-Type (RFC 3875 Section 6.2). + check hs = (lookup hContentType hs `mplus` location) >> case lookup hStatus hs of + Nothing -> Just (maybe ok200 (const found302) location, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where + location = lookup hLocation hs hs' = filter (\(k,_) -> k /= hStatus) hs - toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) + toStatus s = BS.readInt s >>= \(code,msg) -> Just (Status code (BS.dropWhile (== ' ') msg)) emptyHeader = [] - recover (_ :: E.SomeException) = return (CL.sourceNull, emptyHeader) + recover (e :: E.SomeException) + | isAsync e = E.throwIO e + | otherwise = return (CL.sourceNull, emptyHeader) + isAsync e = case E.fromException e of + Just (_ :: E.SomeAsyncException) -> True + Nothing -> False cgiHeader = do (rsrc,hs) <- CB.sourceHandle rhdl $$+ parseHeader src <- toResponseSource rsrc @@ -112,7 +127,7 @@ proSpec naddr epath = CreateProcess { cmdspec = RawCommand prog [] , cwd = Nothing - , env = Just $ makeEnv req naddr scriptName pathinfo (softwareName cspec) epath + , env = Just $ makeEnv req naddr prog scriptName pathinfo (softwareName cspec) epath , std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit @@ -140,13 +155,15 @@ (rawPathInfo req) (indexCgi spec) -makeEnv :: Request -> String -> String -> String -> ByteString -> +makeEnv :: Request -> String -> FilePath -> String -> String -> ByteString -> TRYPATH -> ENVVARS -makeEnv req naddr scriptName pathinfo sname epath = addPath epath . addLen . addType . addCookie $ baseEnv +makeEnv req naddr prog scriptName pathinfo sname epath = + addPath epath . addLen . addType . addPort . addHttps $ baseEnv ++ httpEnv where baseEnv = [ ("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) @@ -159,7 +176,10 @@ headers = requestHeaders req addLen = addLength "CONTENT_LENGTH" $ requestBodyLength req addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers - addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers + addPort = addEnv "REMOTE_PORT" $ remotePort $ remoteHost req + addHttps ev | isSecure req = ("HTTPS", "on") : ev + | otherwise = ev + httpEnv = httpHeadersToEnv headers addPath (Left _) ev = ev addPath (Right path) ev = ("PATH", path) : ev query = BS.unpack . safeTail . rawQueryString @@ -172,6 +192,31 @@ addEnv _ Nothing envs = envs addEnv key (Just val) envs = (key,BS.unpack val) : envs +remotePort :: SockAddr -> Maybe ByteString +remotePort (SockAddrInet p _) = Just $ BS.pack $ show p +remotePort (SockAddrInet6 p _ _ _) = Just $ BS.pack $ show p +remotePort _ = Nothing + +{-| + Converting request headers to HTTP_* variables. + Values of the same header are joined. + +>>> httpHeadersToEnv [("User-Agent","foo"),("Accept","a"),("accept","b"),("Proxy","x"),("Authorization","y"),("Content-Type","z")] +[("HTTP_USER_AGENT","foo"),("HTTP_ACCEPT","a, b")] +-} +httpHeadersToEnv :: RequestHeaders -> ENVVARS +httpHeadersToEnv hdrs = map toEnv $ nub $ map fst relayed + where + relayed = filter (\(k,_) -> k `notElem` excluded) hdrs + -- "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]) + sep k | k == hCookie = "; " + | otherwise = ", " + envName k = "HTTP_" ++ map conv (BS.unpack $ foldedCase k) + conv '-' = '_' + conv c = toUpper c + addLength :: String -> RequestBodyLength -> ENVVARS -> ENVVARS addLength _ ChunkedBody envs = envs addLength key (KnownLength len) envs = (key, show len) : envs @@ -184,6 +229,10 @@ ("/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 "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin" "index.cgi" +("/User/cgi-bin/index.cgi","/cgi-bin/index.cgi","") +>>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin//foo" "index.cgi" +("/User/cgi-bin/index.cgi","/cgi-bin/index.cgi","/foo") -} @@ -191,9 +240,9 @@ pathinfoToCGI src dst path index = (prog, scriptName, pathinfo) where path' = path <\> src - (prog',pathinfo') - | src == path = (index, "") - | otherwise = breakAtSeparator path' + (prog',pathinfo') = case breakAtSeparator path' of + ("", pinfo) -> (index, pinfo) + x -> x prog = pathString (dst prog') scriptName = pathString (src prog') pathinfo = pathString pathinfo' 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\". 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". +-- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". defaultClassicAppSpec :: ClassicAppSpec defaultClassicAppSpec = ClassicAppSpec @@ -17,7 +17,7 @@ ---------------------------------------------------------------- -- | --- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". +-- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.htm\". defaultFileAppSpec :: FileAppSpec defaultFileAppSpec = FileAppSpec 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 @@ -39,7 +39,7 @@ splitDoubleLineBreak str = go str 0 where go bs n - | n < BS.length str = + | n < BS.length bs = case lineBreak bs n of Nothing -> go bs (n + 1) Just n' -> 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 @@ -7,6 +7,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 +import Data.Char (toLower) import qualified Data.Map as Map import Data.Maybe import Data.StaticHash (StaticHash) @@ -20,6 +21,9 @@ import Network.Wai.Application.Classic.Lang import Network.Wai.Application.Classic.Types +-- $setup +-- >>> :set -XOverloadedStrings + ---------------------------------------------------------------- languages :: RequestHeaders -> [ByteString] @@ -36,9 +40,8 @@ locationHeader :: ByteString -> ResponseHeaders locationHeader url = [(hLocation, url)] --- FIXME: the case where "Via:" already exists addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders -addVia cspec req hdr = (hVia, val) : hdr +addVia cspec req = appendHeader hVia val where ver = httpVersion req val = @@ -55,28 +58,52 @@ host = fromMaybe "" $ requestHeaderHost req addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders -addForwardedFor req hdr = (hXForwardedFor, addr) : hdr +addForwardedFor req = appendHeader hXForwardedFor addr where addr = B8.pack . showSockAddr . remoteHost $ req +-- | Appending a value to the existing header if any. +-- +-- >>> appendHeader "X-Forwarded-For" "192.0.2.2" [("Host","a"),("X-Forwarded-For","192.0.2.1")] +-- [("X-Forwarded-For","192.0.2.1, 192.0.2.2"),("Host","a")] +-- >>> appendHeader "X-Forwarded-For" "192.0.2.2" [("Host","a")] +-- [("X-Forwarded-For","192.0.2.2"),("Host","a")] +appendHeader :: HeaderName -> ByteString -> [Header] -> [Header] +appendHeader key val hdr = case [v | (k, v) <- hdr, k == key] of + [] -> (key, val) : hdr + vs -> (key, BS.intercalate ", " (vs ++ [val])) : filter ((/= key) . fst) hdr + newHeader :: Bool -> ByteString -> ResponseHeaders newHeader ishtml file | ishtml = textHtmlHeader | otherwise = [(hContentType, mimeType file)] +-- | +-- >>> mimeType "/var/www/a.html.d/pic.png" +-- "image/png" +-- >>> mimeType "/var/www/www.example.org/README" +-- "application/octet-stream" +-- >>> mimeType "/var/www/PIC.PNG" +-- "image/png" mimeType :: ByteString -> MimeType mimeType file = fromMaybe defaultMimeType . foldr mplus Nothing . map lok $ targets where targets = extensions file lok x = SH.lookup x defaultMimeTypes' +-- | Extensions of the file name, the longest first. +-- +-- >>> extensions "/var/www.d/foo.tar.gz" +-- ["tar.gz","gz"] +-- >>> extensions "/var/www.d/foo" +-- [] extensions :: ByteString -> [ByteString] -extensions file = exts +extensions file = go name where - entire = case BS.break (== 46) file of -- '.' - (_, "") -> "" - (_, x) -> BS.tail x - exts = if entire == "" then [] else entire : BS.split 46 file + name = B8.map toLower $ snd $ BS.breakEnd (== 47) file -- '/' + go x = case BS.break (== 46) x of -- '.' + (_, "") -> [] + (_, ext) -> let ext' = BS.tail ext in ext' : go ext' defaultMimeTypes' :: StaticHash ByteString MimeType defaultMimeTypes' = SH.fromList $ map (first (B8.pack . T.unpack)) $ Map.toList defaultMimeMap 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 @@ -59,6 +59,7 @@ fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req respond = do rspspec <- case method of + _ | hasDotDotSegment (rawPathInfo req) -> return badRequest Right GET -> processGET hinfo ishtml rfile Right HEAD -> processGET hinfo ishtml rfile _ -> return notAllowed @@ -141,11 +142,15 @@ host , rawPathInfo req , "/" + , rawQueryString req ] where host = fromMaybe "" $ requestHeaderHost req ---------------------------------------------------------------- + +badRequest :: RspSpec +badRequest = NoBody badRequest400 notFound :: RspSpec notFound = NoBody notFound404 diff --git a/Network/Wai/Application/Classic/Header.hs b/Network/Wai/Application/Classic/Header.hs --- a/Network/Wai/Application/Classic/Header.hs +++ b/Network/Wai/Application/Classic/Header.hs @@ -4,7 +4,14 @@ module Network.Wai.Application.Classic.Header where import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS (break, tail) +import qualified Data.ByteString.Char8 as BS ( + break, + drop, + isPrefixOf, + null, + take, + uncons, + ) import Network.HTTP.Types.Header import Network.Wai @@ -24,9 +31,38 @@ ---------------------------------------------------------------- +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Network.Wai.Internal (Request (..)) +-- >>> mkReq h = defaultRequest { requestHeaderHost = h } + +-- | +-- Extracting host and port from the Host: header. +-- +-- >>> hostPort (mkReq (Just "example.com:8080")) +-- ("example.com","8080") +-- >>> hostPort (mkReq (Just "example.com")) +-- ("example.com","80") +-- >>> hostPort (mkReq (Just "[::1]:8080")) +-- ("[::1]","8080") +-- >>> hostPort (mkReq (Just "[::1]")) +-- ("[::1]","80") +-- >>> hostPort (mkReq (Just "example.com")) { isSecure = True } +-- ("example.com","443") hostPort :: Request -> (ByteString, ByteString) hostPort req = case requestHeaderHost req of - Nothing -> ("Unknown", "80") - Just hostport -> case BS.break (== ':') hostport of - (host, "") -> (host, "80") - (host, port) -> (host, BS.tail port) + Nothing -> ("Unknown", defaultPort) + Just hostport -> (host, port) + where + (host, rest) + | "[" `BS.isPrefixOf` hostport = + let (h, r) = BS.break (== ']') hostport + in (h <> BS.take 1 r, BS.drop 1 r) + | otherwise = BS.break (== ':') hostport + port = case BS.uncons rest of + Just (':', p) | not (BS.null p) -> p + _ -> defaultPort + where + defaultPort + | isSecure req = "443" + | otherwise = "80" diff --git a/Network/Wai/Application/Classic/Lang.hs b/Network/Wai/Application/Classic/Lang.hs --- a/Network/Wai/Application/Classic/Lang.hs +++ b/Network/Wai/Application/Classic/Lang.hs @@ -13,20 +13,34 @@ space, string, ) -import Data.ByteString.Char8 hiding (count, map, notElem, take, takeWhile) +import Data.ByteString.Char8 hiding ( + count, + filter, + map, + notElem, + take, + takeWhile, + ) +import qualified Data.ByteString.Char8 as B8 (all, null) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.List (sortBy) import Data.Ord import Prelude hiding (takeWhile) --- | +-- | Languages are used as file suffixes, so only safe ones are kept. +-- -- >>> parseLang "en-gb;q=0.8, en;q=0.7, da" -- ["da","en-gb","en"] +-- >>> parseLang "ja;q=0, ../../x, *, en" +-- ["en"] parseLang :: ByteString -> [ByteString] parseLang bs = case parseOnly acceptLanguage bs of - Right ls -> map fst $ sortBy detrimental ls + Right ls -> map fst $ sortBy detrimental $ filter acceptable ls _ -> [] where detrimental = flip (comparing snd) + acceptable (l, q) = q > 0 && not (B8.null l) && B8.all isLangChar l + isLangChar c = isAsciiUpper c || isAsciiLower c || isDigit c || c == '-' ---------------------------------------------------------------- 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 @@ -12,6 +12,7 @@ hasLeadingPathSeparator, hasTrailingPathSeparator, isSuffixOf, + hasDotDotSegment, ) where import Data.ByteString (ByteString) @@ -137,3 +138,19 @@ isSuffixOf :: Path -> Path -> Bool isSuffixOf = BS.isSuffixOf {-# INLINE isSuffixOf #-} + +-- | +-- Checking if the path contains a ".." segment. +-- +-- >>> hasDotDotSegment "/foo/../bar" +-- True +-- >>> hasDotDotSegment "/foo/.." +-- True +-- >>> hasDotDotSegment "/foo\\..\\bar" +-- True +-- >>> hasDotDotSegment "/foo/..bar/baz.." +-- False +hasDotDotSegment :: Path -> Bool +hasDotDotSegment = any (== "..") . BS.splitWith isSep + where + isSep w = w == pathSep || w == 92 -- '\\' 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 @@ -6,13 +6,16 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS (uncons) import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as BS hiding (uncons) +import Data.CaseInsensitive (mk) import Data.Conduit +import Data.IORef import qualified Network.HTTP.Client as H import Network.HTTP.Types import Network.Wai.Application.Classic.Conduit @@ -22,31 +25,66 @@ import Network.Wai.Application.Classic.Types import Network.Wai.Conduit +-- $setup +-- >>> :set -XOverloadedStrings + ---------------------------------------------------------------- -- | Relaying any requests as reverse proxy. revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application -revProxyApp cspec spec route req respond = H.withResponse httpClientRequest mgr proxy +revProxyApp cspec spec route req respond = do + responded <- newIORef False + H.withResponse httpClientRequest mgr (proxy responded) + `E.catch` badGateway responded where - proxy hrsp = do + proxy responded hrsp = do let status = H.responseStatus hrsp hdr = fixHeader $ H.responseHeaders hrsp clientBody = H.responseBody hrsp ct = lookup hContentType hdr src = toSource ct clientBody + writeIORef responded True respond $ responseSource status hdr src + -- The response cannot be replaced once it has been started. + badGateway responded e = do + started <- readIORef responded + if started + then E.throwIO (e :: H.HttpException) + else respond $ responseLBS badGateway502 textPlainHeader "Bad Gateway\r\n" + httpClientRequest = reqToHReq req route mgr = revProxyManager spec - fixHeader = addVia cspec req . filter headerToBeRelay + fixHeader = addVia cspec req . filterHeaders -headerToBeRelay :: Header -> Bool -headerToBeRelay (k, _) - | k == hTransferEncoding = False - | k == hAcceptEncoding = False - | k == hContentLength = False - | k == hContentEncoding = False -- See H.decompress. - | otherwise = True +-- | Removing hop-by-hop headers and ones handled by http-client. +-- +-- >>> filterHeaders [("Connection","close, X-Foo"),("X-Foo","1"),("Keep-Alive","5"),("X-Bar","2")] +-- [("X-Bar","2")] +filterHeaders :: [Header] -> [Header] +filterHeaders hdr = filter (\(k, _) -> k `notElem` excluded) hdr + where + excluded = connectionTokens ++ hopByHop + connectionTokens = + [ mk $ BS.dropWhile (== ' ') $ BS.dropWhileEnd (== ' ') t + | (k, v) <- hdr + , k == hConnection + , t <- BS.split ',' v + ] + hopByHop = + [ hConnection + , "keep-alive" + , "proxy-connection" + , hProxyAuthenticate + , hProxyAuthorization + , hTE + , "trailer" + , hTransferEncoding + , hUpgrade + , hAcceptEncoding + , hContentLength + , hContentEncoding -- See H.decompress. + ] ---------------------------------------------------------------- @@ -56,7 +94,7 @@ { H.host = revProxyDomain route , H.port = revProxyPort route , H.secure = False -- FIXME: upstream is HTTP only - , H.requestHeaders = addForwardedFor req $ filter headerToBeRelay hdr + , H.requestHeaders = addForwardedFor req $ filterHeaders hdr , H.path = path' , H.queryString = dropQuestion query , H.requestBody = bodyToHBody len body @@ -106,15 +144,3 @@ unless (BS.null bs) $ do yield $ Chunk $ byteStringToBuilder bs loop - -{- - -FIXME: -badGateway :: ClassicAppSpec -> Request-> SomeException -> IO Response -badGateway cspec req _ = - return $ responseBuilder st hdr bdy - where - hdr = addServer cspec textPlainHeader - bdy = byteStringToBuilder "Bad Gateway\r\n" - st = badGateway502 --} 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 @@ -31,7 +31,8 @@ statusList :: [Status] statusList = - [ methodNotAllowed405 -- File + [ badRequest400 -- File, CGI + , methodNotAllowed405 -- File , notFound404 -- File , internalServerError500 -- CGI , badGateway502 -- RevProxy 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 @@ -13,7 +13,7 @@ { softwareName :: ByteString -- ^ Name specified to Server: in HTTP response. , statusFileDir :: Path - -- ^ A function to get HTTP's GMT Date. + -- ^ A directory containing HTML files for HTTP status (e.g. 404.html). } data StatusInfo diff --git a/test/ClassicSpec.hs b/test/ClassicSpec.hs --- a/test/ClassicSpec.hs +++ b/test/ClassicSpec.hs @@ -6,6 +6,7 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import Data.List (isPrefixOf) import Network.HTTP import Network.Stream import System.IO @@ -23,10 +24,43 @@ bdy <- rspBody <$> sendPOST url "foo bar.\nbaz!\n" ans <- readFileAscii "test/data/post" bdy `shouldBe` ans + it "accepts a large POST echoed back by the CGI" $ do + let url = "http://127.0.0.1:2345/cgi-bin/cat" + body = replicate 1000000 'x' + bdy <- rspBody <$> sendPOST url body + bdy `shouldBe` body + it "relays the status of the CGI" $ do + let url = "http://127.0.0.1:2345/cgi-bin/not-found" + rsp <- sendGET url + rspCode rsp `shouldBe` (4, 0, 4) + words (rspReason rsp) `shouldBe` ["Not", "Found"] + it "redirects if the CGI returns Location only" $ do + let url = "http://127.0.0.1:2345/cgi-bin/redirect" + rsp <- sendGET url + rspCode rsp `shouldBe` (3, 0, 2) + lookupHeader HdrLocation (rspHeaders rsp) + `shouldBe` Just "http://example.com/" + it "passes request headers as HTTP_* except Proxy" $ do + let url = "http://127.0.0.1:2345/cgi-bin/http-env" + hdr = + [ Header (HdrCustom "X-Foo") "foo" + , Header (HdrCustom "Proxy") "http://evil.example/" + ] + bdy <- rspBody <$> sendGETwH url hdr + lines bdy `shouldBe` ["HTTP_X_FOO: foo", "HTTP_PROXY: ", "REMOTE_PORT: yes"] + it "accepts HEAD" $ do + let url = "http://127.0.0.1:2345/cgi-bin/" + rsp <- sendHEAD url + rspCode rsp `shouldBe` (2, 0, 0) + rspBody rsp `shouldBe` "" it "causes 500 if the CGI script does not behave correctly" $ do 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 400 if the path contains .." $ do + let url = "http://127.0.0.1:2345/cgi-bin/../cgi-bin/index.cgi" + sc <- rspCode <$> sendGET url + sc `shouldBe` (4, 0, 0) describe "fileApp" $ do it "returns index.html for /" $ do let url = "http://127.0.0.1:2345/" @@ -38,10 +72,14 @@ bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/no_extension" bdy `shouldBe` ans - it "returns 400 if not exist" $ do + it "returns 404 if not exist" $ do let url = "http://127.0.0.1:2345/dummy" 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/../../../../../../etc/hosts" + sc <- rspCode <$> sendGET url + sc `shouldBe` (4, 0, 0) it "returns Japanese HTML if language is specified" $ do let url = "http://127.0.0.1:2345/ja/" bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"] @@ -89,11 +127,35 @@ Just lm = lookupHeader HdrLocation hdr sc `shouldBe` (3, 0, 1) lm `shouldBe` "//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 + lookupHeader HdrLocation (rspHeaders rsp) + `shouldBe` Just "//127.0.0.1:2345/redirect/?foo=bar" it "returns index.html for /exact-route.html matching exactRoute" $ do let url = "http://127.0.0.1:2345/exact-route.html" bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/index.html" bdy `shouldBe` ans + 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 + let url = "http://127.0.0.1:2345/upstream/" + hdr = + [ Header HdrProxyAuthorization "secret" + , Header (HdrCustom "X-Forwarded-For") "192.0.2.1" + ] + rsp <- sendGETwH url hdr + let ls = lines $ rspBody rsp + rhdr = rspHeaders rsp + ls `shouldContain` ["x-forwarded-for: 192.0.2.1, 127.0.0.1"] + filter (isPrefixOf "proxy-authorization") ls `shouldBe` [] + lookupHeader (HdrCustom "X-Up") rhdr `shouldBe` Nothing + lookupHeader (HdrCustom "Keep-Alive") rhdr `shouldBe` Nothing + lookupHeader HdrVia rhdr `shouldSatisfy` (/= Nothing) ---------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,6 +6,10 @@ import Control.Concurrent import Control.Monad import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.CaseInsensitive (foldedCase) +import qualified Network.HTTP.Client as H +import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp @@ -17,23 +21,29 @@ main :: IO () main = do void $ installHandler sigCHLD Ignore Nothing - void $ forkIO testServer + mgr <- H.newManager H.defaultManagerSettings + void $ forkIO $ testServer mgr + void $ forkIO upstreamServer threadDelay 100000 hspec spec -testServer :: IO () -testServer = do +testServer :: H.Manager -> IO () +testServer mgr = do dir <- getCurrentDirectory - runSettings settings $ testApp dir + runSettings settings $ testApp mgr dir where settings = setPort 2345 $ setHost "127.0.0.1" defaultSettings -testApp :: FilePath -> Application -testApp dir req +testApp :: H.Manager -> FilePath -> Application +testApp mgr dir req + | revproxy = revProxyApp appSpec (RevProxyAppSpec mgr) revProxyRoute req + | upstream = revProxyApp appSpec (RevProxyAppSpec mgr) upstreamRoute 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 cgi = "/cgi-bin/" `BS.isPrefixOf` rawPathInfo req exact = "/exact-route.html" `BS.isPrefixOf` rawPathInfo req appSpec = defaultClassicAppSpec{softwareName = "ClassicTester"} @@ -52,3 +62,27 @@ { fileSrc = "/" , fileDst = fromString (dir "test/html/") } + -- Nothing should be listening on this port. + revProxyRoute = + RevProxyRoute + { revProxySrc = "/revproxy/" + , revProxyDst = "/" + , revProxyDomain = "127.0.0.1" + , revProxyPort = 1 + } + upstreamRoute = + RevProxyRoute + { revProxySrc = "/upstream/" + , revProxyDst = "/" + , revProxyDomain = "127.0.0.1" + , revProxyPort = 2346 + } + +-- | Echoing request headers with hop-by-hop response headers. +upstreamServer :: IO () +upstreamServer = runSettings settings $ \req respond -> + respond $ responseLBS ok200 hdr $ BL.unlines $ map toLine $ requestHeaders req + where + settings = 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/test/cgi-bin/cat b/test/cgi-bin/cat new file mode 100644 --- /dev/null +++ b/test/cgi-bin/cat @@ -0,0 +1,5 @@ +#! /bin/sh + +echo "Content-Type: text/plain" +echo "" +cat - diff --git a/test/cgi-bin/http-env b/test/cgi-bin/http-env new file mode 100644 --- /dev/null +++ b/test/cgi-bin/http-env @@ -0,0 +1,7 @@ +#! /bin/sh + +echo "Content-Type: text/plain" +echo "" +echo "HTTP_X_FOO: $HTTP_X_FOO" +echo "HTTP_PROXY: $HTTP_PROXY" +echo "REMOTE_PORT: ${REMOTE_PORT:+yes}" diff --git a/test/cgi-bin/not-found b/test/cgi-bin/not-found new file mode 100644 --- /dev/null +++ b/test/cgi-bin/not-found @@ -0,0 +1,6 @@ +#! /bin/sh + +echo "Content-Type: text/plain" +echo "Status: 404 Not Found" +echo "" +echo "not found" diff --git a/test/cgi-bin/redirect b/test/cgi-bin/redirect new file mode 100644 --- /dev/null +++ b/test/cgi-bin/redirect @@ -0,0 +1,4 @@ +#! /bin/sh + +echo "Location: http://example.com/" +echo "" 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.1 +version: 3.2.2 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -20,7 +20,11 @@ extra-source-files: test/cgi-bin/index.cgi test/cgi-bin/broken + test/cgi-bin/cat test/cgi-bin/echo-env + test/cgi-bin/http-env + test/cgi-bin/not-found + test/cgi-bin/redirect test/data/post test/html/index.html test/html/ja/index.html.ja @@ -92,11 +96,13 @@ 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,