wai-app-file-cgi 3.2.1 → 3.2.2
raw patch · 19 files changed
+412/−80 lines, 19 filesdep ~http-client
Dependency ranges changed: http-client
Files
- CHANGELOG.md +33/−0
- Network/Wai/Application/Classic/CGI.hs +77/−28
- Network/Wai/Application/Classic/Def.hs +2/−2
- Network/Wai/Application/Classic/EventSource.hs +1/−1
- Network/Wai/Application/Classic/Field.hs +35/−8
- Network/Wai/Application/Classic/File.hs +5/−0
- Network/Wai/Application/Classic/Header.hs +41/−5
- Network/Wai/Application/Classic/Lang.hs +17/−3
- Network/Wai/Application/Classic/Path.hs +17/−0
- Network/Wai/Application/Classic/RevProxy.hs +49/−23
- Network/Wai/Application/Classic/Status.hs +2/−1
- Network/Wai/Application/Classic/Types.hs +1/−1
- test/ClassicSpec.hs +63/−1
- test/Spec.hs +40/−6
- test/cgi-bin/cat +5/−0
- test/cgi-bin/http-env +7/−0
- test/cgi-bin/not-found +6/−0
- test/cgi-bin/redirect +4/−0
- wai-app-file-cgi.cabal +7/−1
CHANGELOG.md view
@@ -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
Network/Wai/Application/Classic/CGI.hs view
@@ -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'
Network/Wai/Application/Classic/Def.hs view
@@ -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
Network/Wai/Application/Classic/EventSource.hs view
@@ -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' ->
Network/Wai/Application/Classic/Field.hs view
@@ -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
Network/Wai/Application/Classic/File.hs view
@@ -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
Network/Wai/Application/Classic/Header.hs view
@@ -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"
Network/Wai/Application/Classic/Lang.hs view
@@ -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 == '-' ----------------------------------------------------------------
Network/Wai/Application/Classic/Path.hs view
@@ -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 -- '\\'
Network/Wai/Application/Classic/RevProxy.hs view
@@ -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--}
Network/Wai/Application/Classic/Status.hs view
@@ -31,7 +31,8 @@ statusList :: [Status] statusList =- [ methodNotAllowed405 -- File+ [ badRequest400 -- File, CGI+ , methodNotAllowed405 -- File , notFound404 -- File , internalServerError500 -- CGI , badGateway502 -- RevProxy
Network/Wai/Application/Classic/Types.hs view
@@ -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
test/ClassicSpec.hs view
@@ -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) ----------------------------------------------------------------
test/Spec.hs view
@@ -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]
+ test/cgi-bin/cat view
@@ -0,0 +1,5 @@+#! /bin/sh++echo "Content-Type: text/plain"+echo ""+cat -
+ test/cgi-bin/http-env view
@@ -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}"
+ test/cgi-bin/not-found view
@@ -0,0 +1,6 @@+#! /bin/sh++echo "Content-Type: text/plain"+echo "Status: 404 Not Found"+echo ""+echo "not found"
+ test/cgi-bin/redirect view
@@ -0,0 +1,4 @@+#! /bin/sh++echo "Location: http://example.com/"+echo ""
wai-app-file-cgi.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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,