diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 3.0.5 + +Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful +since, for example, Amazon ELB HTTP does *not* have support for Websockets. +More information on the protocol [is available from +Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol). + ## 3.0.4 Added `setFork`. diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -44,6 +44,9 @@ , setServerName , setMaximumBodyFlush , setFork + , setProxyProtocolNone + , setProxyProtocolRequired + , setProxyProtocolOptional -- ** Getters , getPort , getHost @@ -241,3 +244,41 @@ -- Since 3.0.4 setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings setFork fork' s = s { settingsFork = fork' } + +-- | Do not use the PROXY protocol. +-- +-- Since 3.0.5 +setProxyProtocolNone :: Settings -> Settings +setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone } + +-- | Require PROXY header. +-- +-- This is for cases where a "dumb" TCP/SSL proxy is being used, which cannot +-- add an @X-Forwarded-For@ HTTP header field but has enabled support for the +-- PROXY protocol. +-- +-- See and +-- . +-- +-- Only the human-readable header format (version 1) is supported. The binary +-- header format (version 2) is /not/ supported. +-- +-- Since 3.0.5 +setProxyProtocolRequired :: Settings -> Settings +setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired } + +-- | Use the PROXY header if it exists, but also accept +-- connections without the header. See 'setProxyProtocolRequired'. +-- +-- WARNING: This is contrary to the PROXY protocol specification and +-- using it can indicate a security problem with your +-- architecture if the web server is directly accessable +-- to the public, since it would allow easy IP address +-- spoofing. However, it can be useful in some cases, +-- such as if a load balancer health check uses regular +-- HTTP without the PROXY header, but proxied +-- connections /do/ include the PROXY header. +-- +-- Since 3.0.5 +setProxyProtocolOptional :: Settings -> Settings +setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional } diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -13,10 +13,12 @@ import Control.Monad (when, unless, void) import Data.ByteString (ByteString) import qualified Data.ByteString as S +import Data.Char (chr) +import Data.IP (toHostAddress, toHostAddress6) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Network (sClose, Socket) -import Network.Socket (accept, withSocketsDo, SockAddr) +import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6)) import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Handler.Warp.Buffer @@ -24,6 +26,7 @@ import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import Network.Wai.Handler.Warp.Header +import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response @@ -271,28 +274,69 @@ -> Settings -> Application -> IO () -serveConnection conn ii addr isSecure' settings app = do +serveConnection conn ii origAddr isSecure' settings app = do istatus <- newIORef False src <- mkSource (connSource conn th istatus) - recvSendLoop istatus src `E.catch` \e -> do - sendErrorResponse istatus e + addr <- getProxyProtocolAddr src + recvSendLoop addr istatus src `E.catch` \e -> do + sendErrorResponse addr istatus e throwIO (e :: SomeException) where + getProxyProtocolAddr src = + case settingsProxyProtocol settings of + ProxyProtocolNone -> + return origAddr + ProxyProtocolRequired -> do + seg <- readSource src + parseProxyProtocolHeader src seg + ProxyProtocolOptional -> do + seg <- readSource src + if S.isPrefixOf "PROXY " seg + then parseProxyProtocolHeader src seg + else do leftoverSource src seg + return origAddr + + parseProxyProtocolHeader src seg = do + let (header,seg') = S.break (== 0x0d) seg -- 0x0d == CR + maybeAddr = case S.split 0x20 header of -- 0x20 == space + ["PROXY","TCP4",clientAddr,_,clientPort,_] -> + case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of + [a] -> Just (SockAddrInet (readInt clientPort) + (toHostAddress a)) + _ -> Nothing + ["PROXY","TCP6",clientAddr,_,clientPort,_] -> + case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of + [a] -> Just (SockAddrInet6 (readInt clientPort) + 0 + (toHostAddress6 a) + 0) + _ -> Nothing + ("PROXY":"UNKNOWN":_) -> + Just origAddr + _ -> + Nothing + case maybeAddr of + Nothing -> throwIO (BadProxyHeader (decodeAscii header)) + Just a -> do leftoverSource src (S.drop 2 seg') -- drop CRLF + return a + + decodeAscii = map (chr . fromEnum) . S.unpack + th = threadHandle ii - sendErrorResponse istatus e = do + sendErrorResponse addr istatus e = do status <- readIORef istatus when status $ void $ sendResponse (settingsServerName settings) - conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e) + conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e) - dummyreq = defaultRequest { remoteHost = addr } + dummyreq addr = defaultRequest { remoteHost = addr } errorResponse e = settingsOnExceptionResponse settings e - recvSendLoop istatus fromClient = do + recvSendLoop addr istatus fromClient = do (req', mremainingRef, idxhdr) <- recvRequest settings conn ii addr fromClient let req = req' { isSecure = isSecure' } -- Let the application run for as long as it wants @@ -333,14 +377,14 @@ Nothing -> do flushEntireBody (requestBody req) T.resume th - recvSendLoop istatus fromClient + recvSendLoop addr istatus fromClient Just maxToRead -> do let tryKeepAlive = do -- flush the rest of the request body isComplete <- flushBody (requestBody req) maxToRead when isComplete $ do T.resume th - recvSendLoop istatus fromClient + recvSendLoop addr istatus fromClient case mremainingRef of Just ref -> do remaining <- readIORef ref diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -82,8 +82,20 @@ -- ^ See @setMaximumBodyFlush@. -- -- Since 3.0.3 + , settingsProxyProtocol :: ProxyProtocol + -- ^ Specify usage of the PROXY protocol. + -- + -- Since 3.0.5. } +-- | Specify usage of the PROXY protocol. +data ProxyProtocol = ProxyProtocolNone + -- ^ See @setProxyProtocolNone@. + | ProxyProtocolRequired + -- ^ See @setProxyProtocolRequired@. + | ProxyProtocolOptional + -- ^ See @setProxyProtocolOptional@. + -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings @@ -103,6 +115,7 @@ , settingsInstallShutdownHandler = const $ return () , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version , settingsMaximumBodyFlush = Just 8192 + , settingsProxyProtocol = ProxyProtocolNone } -- | Apply the logic provided by 'defaultExceptionHandler' to determine if an diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -47,6 +47,7 @@ | IncompleteHeaders | ConnectionClosedByPeer | OverLargeHeader + | BadProxyHeader String deriving (Eq, Typeable) instance Show InvalidRequest where @@ -56,6 +57,7 @@ show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely" show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." + show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s instance Exception InvalidRequest diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.0.4.1 +Version: 3.0.5 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -35,6 +35,7 @@ , case-insensitive >= 0.2 , ghc-prim , http-types >= 0.8.5 + , iproute >= 1.3.1 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , void @@ -117,6 +118,7 @@ , ghc-prim , HTTP , http-types >= 0.8.4 + , iproute >= 1.3.1 , lifted-base >= 0.1 , simple-sendfile >= 0.2.4 && < 0.3 , transformers >= 0.2.2