io-streams-haproxy-1.0.0.1/0000755000000000000000000000000012752734153013621 5ustar0000000000000000io-streams-haproxy-1.0.0.1/CONTRIBUTORS0000644000000000000000000000036212752734153015502 0ustar0000000000000000------------------------------------------------------------------------------ Contributors to io-streams-haproxy: - Gregory Collins ------------------------------------------------------------------------------ io-streams-haproxy-1.0.0.1/io-streams-haproxy.cabal0000644000000000000000000000561312752734153020365 0ustar0000000000000000name: io-streams-haproxy version: 1.0.0.1 synopsis: HAProxy protocol 1.5 support for io-streams description: HAProxy protocol version 1.5 support (see ) for applications using io-streams. The proxy protocol allows information about a networked peer (like remote address and port) to be propagated through a forwarding proxy that is configured to speak this protocol. homepage: http://snapframework.com/ license: BSD3 license-file: LICENSE author: Gregory Collins maintainer: greg@gregorycollins.net copyright: (c) 2014 Google, Inc. and CONTRIBUTORS category: Network, IO-Streams build-type: Simple extra-source-files: CONTRIBUTORS, cbits/byteorder.c cabal-version: >=1.10 Bug-Reports: https://github.com/snapframework/io-streams-haproxy/issues Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 source-repository head type: git location: https://github.com/snapframework/io-streams-haproxy.git library hs-source-dirs: src exposed-modules: System.IO.Streams.Network.HAProxy other-modules: System.IO.Streams.Network.Internal.Address c-sources: cbits/byteorder.c build-depends: base >= 4.5 && < 4.10, attoparsec >= 0.7 && < 0.14, bytestring >= 0.9 && < 0.11, io-streams >= 1.3 && < 1.4, network >= 2.3 && < 2.7, transformers >= 0.3 && < 0.6 default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind if os(windows) cpp-options: -DWINDOWS cc-options: -DWINDOWS test-suite testsuite type: exitcode-stdio-1.0 hs-source-dirs: src test Main-is: TestSuite.hs Default-language: Haskell2010 c-sources: cbits/byteorder.c ghc-options: -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind Other-modules: System.IO.Streams.Network.HAProxy, System.IO.Streams.Network.HAProxy.Tests, System.IO.Streams.Network.Internal.Address build-depends: base, attoparsec, bytestring, io-streams, network, transformers, ------------------------------ HUnit >= 1.2 && <2, test-framework >= 0.8.0.3 && <0.9, test-framework-hunit >= 0.2.7 && <0.4 if os(windows) cpp-options: -DWINDOWS cc-options: -DWINDOWS io-streams-haproxy-1.0.0.1/LICENSE0000644000000000000000000000267112752734153014634 0ustar0000000000000000Copyright (c) 2012, Google, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the names of Google, nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. io-streams-haproxy-1.0.0.1/Setup.hs0000644000000000000000000000005612752734153015256 0ustar0000000000000000import Distribution.Simple main = defaultMain io-streams-haproxy-1.0.0.1/cbits/0000755000000000000000000000000012752734153014725 5ustar0000000000000000io-streams-haproxy-1.0.0.1/cbits/byteorder.c0000644000000000000000000000111712752734153017070 0ustar0000000000000000/* Sigh. According to the docs for , htonl() and friends may be implemented as macros only, so I have to re-export functions here to do the conversions. */ #if defined(WINDOWS) # include # include #else # include #endif uint32_t iostreams_htonl(uint32_t hostlong) { return htonl(hostlong); } uint16_t iostreams_htons(uint16_t hostshort) { return htons(hostshort); } uint32_t iostreams_ntohl(uint32_t netlong) { return ntohl(netlong); } uint16_t iostreams_ntohs(uint16_t netshort) { return ntohs(netshort); } io-streams-haproxy-1.0.0.1/src/0000755000000000000000000000000012752734153014410 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/0000755000000000000000000000000012752734153015674 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/IO/0000755000000000000000000000000012752734153016203 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/IO/Streams/0000755000000000000000000000000012752734153017621 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/IO/Streams/Network/0000755000000000000000000000000012752734153021252 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/IO/Streams/Network/HAProxy.hs0000644000000000000000000003422712752734153023150 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TupleSections #-} {-| HAProxy proxying protocol support (see ) for applications using io-streams. The proxy protocol allows information about a networked peer (like remote address and port) to be propagated through a forwarding proxy that is configured to speak this protocol. This approach is safer than other alternatives like injecting a special HTTP header (like "X-Forwarded-For") because the data is sent out of band, requests without the proxy header fail, and proxy data cannot be spoofed by the client. -} module System.IO.Streams.Network.HAProxy ( -- * Proxying requests. behindHAProxy , behindHAProxyWithLocalInfo , decodeHAProxyHeaders -- * Information about proxied requests. , ProxyInfo , socketToProxyInfo , makeProxyInfo , getSourceAddr , getDestAddr , getFamily , getSocketType ) where ------------------------------------------------------------------------------ import Control.Applicative ((<|>)) import Control.Monad (void, when) import Data.Attoparsec.ByteString (anyWord8) import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, skipWhile, string, take, takeWhile1) import Data.Bits (unsafeShiftR, (.&.)) import qualified Data.ByteString as S8 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import Data.Word (Word16, Word32, Word8) import Foreign.C.Types (CUInt (..), CUShort (..)) import Foreign.Ptr (castPtr) import Foreign.Storable (peek) import qualified Network.Socket as N import Prelude hiding (take) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams import System.IO.Streams.Network.Internal.Address (getSockAddr) import System.IO.Unsafe (unsafePerformIO) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Make a 'ProxyInfo' from a connected socket. socketToProxyInfo :: N.Socket -> N.SockAddr -> IO ProxyInfo socketToProxyInfo s sa = do da <- N.getSocketName s let (N.MkSocket _ _ !sty _ _) = s return $! makeProxyInfo sa da (addrFamily sa) sty ------------------------------------------------------------------------------ -- | Parses the proxy headers emitted by HAProxy and runs a user action with -- the origin/destination socket addresses provided by HAProxy. Will throw a -- 'Sockets.ParseException' if the protocol header cannot be parsed properly. -- -- We support version 1.5 of the protocol (both the "old" text protocol and the -- "new" binary protocol.). Typed data fields after the addresses are not (yet) -- supported. -- behindHAProxy :: N.Socket -- ^ A socket you've just accepted -> N.SockAddr -- ^ and its peer address -> (ProxyInfo -> InputStream ByteString -> OutputStream ByteString -> IO a) -> IO a behindHAProxy socket sa m = do pinfo <- socketToProxyInfo socket sa sockets <- Streams.socketToStreams socket behindHAProxyWithLocalInfo pinfo sockets m ------------------------------------------------------------------------------ -- | Like 'behindHAProxy', but allows the socket addresses and input/output -- streams to be passed in instead of created based on an input 'Socket'. -- Useful for unit tests. -- behindHAProxyWithLocalInfo :: ProxyInfo -- ^ local socket info -> (InputStream ByteString, OutputStream ByteString) -- ^ socket streams -> (ProxyInfo -> InputStream ByteString -> OutputStream ByteString -> IO a) -- ^ user function -> IO a behindHAProxyWithLocalInfo localProxyInfo (is, os) m = do proxyInfo <- decodeHAProxyHeaders localProxyInfo is m proxyInfo is os ------------------------------------------------------------------------------ decodeHAProxyHeaders :: ProxyInfo -> (InputStream ByteString) -> IO ProxyInfo decodeHAProxyHeaders localProxyInfo is0 = do -- 536 bytes as per spec is <- Streams.throwIfProducesMoreThan 536 is0 (!isOld, !mbOldInfo) <- Streams.parseFromStream (((True,) <$> parseOldHaProxy) <|> return (False, Nothing)) is if isOld then maybe (return localProxyInfo) (\(srcAddr, srcPort, destAddr, destPort, f) -> do (_, s) <- getSockAddr srcPort srcAddr (_, d) <- getSockAddr destPort destAddr return $! makeProxyInfo s d f $ getSocketType localProxyInfo) mbOldInfo else Streams.parseFromStream (parseNewHaProxy localProxyInfo) is ------------------------------------------------------------------------------ -- | Stores information about the proxied request. data ProxyInfo = ProxyInfo { _sourceAddr :: N.SockAddr , _destAddr :: N.SockAddr , _family :: N.Family , _sockType :: N.SocketType } deriving (Show) ------------------------------------------------------------------------------ -- | Gets the 'N.Family' of the proxied request (i.e. IPv4/IPv6/Unix domain -- sockets). getFamily :: ProxyInfo -> N.Family getFamily p = _family p ------------------------------------------------------------------------------ -- | Gets the 'N.SocketType' of the proxied request (UDP/TCP). getSocketType :: ProxyInfo -> N.SocketType getSocketType p = _sockType p ------------------------------------------------------------------------------ -- | Gets the network address of the source node for this request (i.e. the -- client). getSourceAddr :: ProxyInfo -> N.SockAddr getSourceAddr p = _sourceAddr p ------------------------------------------------------------------------------ -- | Gets the network address of the destination node for this request (i.e. the -- client). getDestAddr :: ProxyInfo -> N.SockAddr getDestAddr p = _destAddr p ------------------------------------------------------------------------------ -- | Makes a 'ProxyInfo' object. makeProxyInfo :: N.SockAddr -- ^ the source address -> N.SockAddr -- ^ the destination address -> N.Family -- ^ the socket family -> N.SocketType -- ^ the socket type -> ProxyInfo makeProxyInfo srcAddr destAddr f st = ProxyInfo srcAddr destAddr f st ------------------------------------------------------------------------------ parseFamily :: Parser (Maybe N.Family) parseFamily = (string "TCP4" >> return (Just N.AF_INET)) <|> (string "TCP6" >> return (Just N.AF_INET6)) <|> (string "UNKNOWN" >> return Nothing) ------------------------------------------------------------------------------ parseOldHaProxy :: Parser (Maybe (ByteString, Int, ByteString, Int, N.Family)) parseOldHaProxy = do string "PROXY " gotFamily <- parseFamily case gotFamily of Nothing -> skipWhile (/= '\r') >> string "\r\n" >> return Nothing (Just f) -> do char ' ' srcAddress <- takeWhile1 (/= ' ') char ' ' destAddress <- takeWhile1 (/= ' ') char ' ' srcPort <- decimal char ' ' destPort <- decimal string "\r\n" return $! Just $! (srcAddress, srcPort, destAddress, destPort, f) ------------------------------------------------------------------------------ protocolHeader :: ByteString protocolHeader = S8.pack [ 0x0D, 0x0A, 0x0D, 0x0A, 0x00, 0x0D , 0x0A, 0x51, 0x55, 0x49, 0x54, 0x0A ] {-# NOINLINE protocolHeader #-} ------------------------------------------------------------------------------ parseNewHaProxy :: ProxyInfo -> Parser ProxyInfo parseNewHaProxy localProxyInfo = do string protocolHeader versionAndCommand <- anyWord8 let version = (versionAndCommand .&. 0xF0) `unsafeShiftR` 4 let command = (versionAndCommand .&. 0xF) :: Word8 when (version /= 0x2) $ fail $ "Invalid protocol version: " ++ show version when (command > 1) $ fail $ "Invalid command: " ++ show command protocolAndFamily <- anyWord8 let family = (protocolAndFamily .&. 0xF0) `unsafeShiftR` 4 let protocol = (protocolAndFamily .&. 0xF) :: Word8 -- VALUES FOR FAMILY -- 0x0 : AF_UNSPEC : the connection is forwarded for an unknown, -- unspecified or unsupported protocol. The sender should use this family -- when sending LOCAL commands or when dealing with unsupported protocol -- families. The receiver is free to accept the connection anyway and use -- the real endpoint addresses or to reject it. The receiver should ignore -- address information. -- 0x1 : AF_INET : the forwarded connection uses the AF_INET address family -- (IPv4). The addresses are exactly 4 bytes each in network byte order, -- followed by transport protocol information (typically ports). -- 0x2 : AF_INET6 : the forwarded connection uses the AF_INET6 address -- family (IPv6). The addresses are exactly 16 bytes each in network byte -- order, followed by transport protocol information (typically ports). -- -- 0x3 : AF_UNIX : the forwarded connection uses the AF_UNIX address family -- (UNIX). The addresses are exactly 108 bytes each. socketType <- toSocketType protocol addressLen <- ntohs <$> snarf16 case () of !_ | command == 0x0 || family == 0x0 || protocol == 0x0 -- LOCAL -> handleLocal addressLen | family == 0x1 -> handleIPv4 addressLen socketType | family == 0x2 -> handleIPv6 addressLen socketType #ifndef WINDOWS | family == 0x3 -> handleUnix addressLen socketType #endif | otherwise -> fail $ "Bad family " ++ show family where toSocketType 0 = return $! N.Stream toSocketType 1 = return $! N.Stream toSocketType 2 = return $! N.Datagram toSocketType _ = fail "bad protocol" handleLocal addressLen = do -- skip N bytes and return the original addresses when (addressLen > 500) $ fail $ "suspiciously long address " ++ show addressLen void $ take (fromIntegral addressLen) return localProxyInfo handleIPv4 addressLen socketType = do when (addressLen < 12) $ fail $ "bad address length " ++ show addressLen ++ " for IPv4" let nskip = addressLen - 12 srcAddr <- snarf32 destAddr <- snarf32 srcPort <- ntohs <$> snarf16 destPort <- ntohs <$> snarf16 void $ take $ fromIntegral nskip -- Note: we actually want the brain-dead constructors here let sa = N.SockAddrInet (fromIntegral srcPort) srcAddr let sb = N.SockAddrInet (fromIntegral destPort) destAddr return $! makeProxyInfo sa sb (addrFamily sa) socketType handleIPv6 addressLen socketType = do let scopeId = 0 -- means "reserved", kludge alert! let flow = 0 when (addressLen < 36) $ fail $ "bad address length " ++ show addressLen ++ " for IPv6" let nskip = addressLen - 36 s1 <- ntohl <$> snarf32 s2 <- ntohl <$> snarf32 s3 <- ntohl <$> snarf32 s4 <- ntohl <$> snarf32 d1 <- ntohl <$> snarf32 d2 <- ntohl <$> snarf32 d3 <- ntohl <$> snarf32 d4 <- ntohl <$> snarf32 sp <- ntohs <$> snarf16 dp <- ntohs <$> snarf16 void $ take $ fromIntegral nskip let sa = N.SockAddrInet6 (fromIntegral sp) flow (s1, s2, s3, s4) scopeId let sb = N.SockAddrInet6 (fromIntegral dp) flow (d1, d2, d3, d4) scopeId return $! makeProxyInfo sa sb (addrFamily sa) socketType #ifndef WINDOWS handleUnix addressLen socketType = do when (addressLen < 216) $ fail $ "bad address length " ++ show addressLen ++ " for unix" addr1 <- take 108 addr2 <- take 108 void $ take $ fromIntegral $ addressLen - 216 let sa = N.SockAddrUnix (toUnixPath addr1) let sb = N.SockAddrUnix (toUnixPath addr2) return $! makeProxyInfo sa sb (addrFamily sa) socketType toUnixPath = S.unpack . fst . S.break (=='\x00') #endif foreign import ccall unsafe "iostreams_ntohs" c_ntohs :: CUShort -> CUShort foreign import ccall unsafe "iostreams_ntohl" c_ntohl :: CUInt -> CUInt ntohs :: Word16 -> Word16 ntohs = fromIntegral . c_ntohs . fromIntegral ntohl :: Word32 -> Word32 ntohl = fromIntegral . c_ntohl . fromIntegral snarf32 :: Parser Word32 snarf32 = do s <- take 4 return $! unsafePerformIO $! S.unsafeUseAsCString s $ peek . castPtr snarf16 :: Parser Word16 snarf16 = do s <- take 2 return $! unsafePerformIO $! S.unsafeUseAsCString s $ peek . castPtr addrFamily :: N.SockAddr -> N.Family addrFamily s = case s of (N.SockAddrInet _ _) -> N.AF_INET (N.SockAddrInet6 _ _ _ _) -> N.AF_INET6 #ifndef WINDOWS (N.SockAddrUnix _ ) -> N.AF_UNIX #endif _ -> error "unknown family" io-streams-haproxy-1.0.0.1/src/System/IO/Streams/Network/Internal/0000755000000000000000000000000012752734153023026 5ustar0000000000000000io-streams-haproxy-1.0.0.1/src/System/IO/Streams/Network/Internal/Address.hs0000644000000000000000000000351712752734153024755 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Network.Internal.Address ( getSockAddr , getSockAddrImpl , AddressNotSupportedException(..) ) where ------------------------------------------------------------------------------ import Control.Exception (Exception, throwIO) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Typeable (Typeable) import Network.Socket (AddrInfo (addrAddress, addrFamily, addrFlags), AddrInfoFlag (AI_NUMERICSERV), Family, SockAddr, defaultHints, getAddrInfo) ------------------------------------------------------------------------------ data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) instance Show AddressNotSupportedException where show (AddressNotSupportedException x) = "Address not supported: " ++ x instance Exception AddressNotSupportedException ------------------------------------------------------------------------------ getSockAddr :: Int -> ByteString -> IO (Family, SockAddr) getSockAddr = getSockAddrImpl getAddrInfo ------------------------------------------------------------------------------ getSockAddrImpl :: (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]) -> Int -> ByteString -> IO (Family, SockAddr) getSockAddrImpl !_getAddrInfo p s = do ais <- _getAddrInfo (Just hints) (Just $ S.unpack s) (Just $ show p) if null ais then throwIO $ AddressNotSupportedException $ show s else do let !ai = head ais let !fm = addrFamily ai let !sa = addrAddress ai return (fm, sa) where hints = defaultHints { addrFlags = [AI_NUMERICSERV] } io-streams-haproxy-1.0.0.1/test/0000755000000000000000000000000012752734153014600 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/TestSuite.hs0000644000000000000000000000054112752734153017065 0ustar0000000000000000module Main where import qualified System.IO.Streams.Network.HAProxy.Tests as HAProxy import Test.Framework (defaultMain, testGroup) ------------------------------------------------------------------------------ main :: IO () main = defaultMain tests where tests = [ testGroup "Tests.HAProxy" HAProxy.tests ] io-streams-haproxy-1.0.0.1/test/System/0000755000000000000000000000000012752734153016064 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/System/IO/0000755000000000000000000000000012752734153016373 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/System/IO/Streams/0000755000000000000000000000000012752734153020011 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/System/IO/Streams/Network/0000755000000000000000000000000012752734153021442 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/System/IO/Streams/Network/HAProxy/0000755000000000000000000000000012752734153022774 5ustar0000000000000000io-streams-haproxy-1.0.0.1/test/System/IO/Streams/Network/HAProxy/Tests.hs0000644000000000000000000006111012752734153024431 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module System.IO.Streams.Network.HAProxy.Tests (tests) where ------------------------------------------------------------------------------ import Control.Applicative ((<$>)) import Control.Concurrent import qualified Control.Exception as E import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString as S8 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Typeable import qualified Network.Socket as N import System.IO (hPutStrLn, stderr) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Network.HAProxy as HA import System.IO.Streams.Network.Internal.Address (AddressNotSupportedException (..), getSockAddr, getSockAddrImpl) import System.Timeout (timeout) import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ tests :: [Test] tests = [ testOldHaProxy , testOldHaProxy6 , testOldHaProxyFailure , testOldHaProxyLocal , testOldHaProxyLocal6 , testOldHaProxyBadAddress , testBlackBox , testBlackBoxLocal , testNewHaProxy #ifndef WINDOWS , testNewHaProxyUnix #endif , testNewHaProxy6 , testNewHaProxyTooBig , testNewHaProxyTooSmall , testNewHaProxyBadVersion , testNewHaProxyLocal , testGetSockAddr , testTrivials ] ------------------------------------------------------------------------------ runInput :: ByteString -> N.SockAddr -> N.SockAddr -> (HA.ProxyInfo -> InputStream ByteString -> OutputStream ByteString -> IO a) -> IO a runInput input sa sb action = do is <- Streams.fromList [input] (os, _) <- Streams.listOutputStream let pinfo = HA.makeProxyInfo sa sb (addrFamily sa) N.Stream HA.behindHAProxyWithLocalInfo pinfo (is, os) action ------------------------------------------------------------------------------ addrFamily :: N.SockAddr -> N.Family addrFamily s = case s of (N.SockAddrInet _ _) -> N.AF_INET (N.SockAddrInet6 _ _ _ _) -> N.AF_INET6 #ifndef WINDOWS (N.SockAddrUnix _ ) -> N.AF_UNIX #endif ------------------------------------------------------------------------------ blackbox :: (Chan Bool -> HA.ProxyInfo -> InputStream ByteString -> OutputStream ByteString -> IO ()) -> ByteString -> IO () blackbox action input = withTimeout 10 $ do chan <- newChan E.bracket (startServer chan) (killThread . fst) client readChan chan >>= assertBool "success" where client (_, port) = do (family, addr) <- getSockAddr port "127.0.0.1" E.bracket (N.socket family N.Stream 0) N.close $ \sock -> do N.connect sock addr (_, os) <- Streams.socketToStreams sock threadDelay 10000 Streams.write (Just input) os Streams.write Nothing os threadDelay 10000 withTimeout n m = timeout (n * 1000000) m >>= maybe (fail "timeout") return startServer :: Chan Bool -> IO (ThreadId, Int) startServer = E.bracketOnError getSock N.close . forkServer getSock = do (family, addr) <- getSockAddr (fromIntegral N.aNY_PORT) "127.0.0.1" sock <- N.socket family N.Stream 0 N.setSocketOption sock N.ReuseAddr 1 N.setSocketOption sock N.NoDelay 1 N.bindSocket sock addr N.listen sock 150 return $! sock forkServer chan sock = do port <- fromIntegral <$> N.socketPort sock tid <- E.mask_ $ forkIOWithUnmask $ server chan sock return (tid, port) server :: Chan Bool -> N.Socket -> (forall z. IO z -> IO z) -> IO () server chan boundSocket restore = loop `E.finally` N.close boundSocket where loop = forever $ E.bracketOnError (restore $ N.accept boundSocket) (N.close . fst) (\(sock, sa) -> forkIOWithUnmask $ \r -> flip E.finally (N.close sock) $ r $ HA.behindHAProxy sock sa (action chan)) ------------------------------------------------------------------------------ testBlackBox :: Test testBlackBox = testCase "test/blackbox" $ blackbox action "PROXY TCP4 127.0.0.1 127.0.0.1 10000 80\r\nblah" where action chan proxyInfo !is !_ = do sa <- localhost 10000 sb <- localhost 80 x <- E.try $ do assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] case x of Left (e :: E.SomeException) -> do hPutStrLn stderr $ show e writeChan chan False Right !_ -> writeChan chan True ------------------------------------------------------------------------------ testBlackBoxLocal :: Test testBlackBoxLocal = testCase "test/blackbox_local" $ blackbox action "PROXY UNKNOWN\r\nblah" where action chan proxyInfo !is !_ = do let q = HA.getSourceAddr proxyInfo `seq` HA.getDestAddr proxyInfo `seq` () x <- q `seq` E.try $ go is proxyInfo case x of Left (e :: E.SomeException) -> do hPutStrLn stderr $ show e writeChan chan False Right !_ -> writeChan chan True go is proxyInfo = do Streams.toList is >>= assertEqual "rest" ["blah"] assertEqual "family" N.AF_INET $ HA.getFamily proxyInfo assertEqual "type" N.Stream $ HA.getSocketType proxyInfo ------------------------------------------------------------------------------ testOldHaProxy :: Test testOldHaProxy = testCase "test/old_ha_proxy" $ do sa <- localhost 1111 sb <- localhost 2222 runInput "PROXY TCP4 127.0.0.1 127.0.0.1 10000 80\r\nblah" sa sb action where action proxyInfo !is !_ = do sa <- localhost 10000 sb <- localhost 80 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ testOldHaProxy6 :: Test testOldHaProxy6 = testCase "test/old_ha_proxy6" $ do sa <- localhost6 1111 sb <- localhost6 2222 runInput "PROXY TCP6 ::1 ::1 10000 80\r\nblah" sa sb action where action proxyInfo !is !_ = do sa <- localhost6 10000 sb <- localhost6 80 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET6 $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ testOldHaProxyLocal :: Test testOldHaProxyLocal = testCase "test/old_ha_proxy_local" $ do sa <- localhost 1111 sb <- localhost 2222 runInput "PROXY UNKNOWN\r\nblah" sa sb action where action proxyInfo !is !_ = do sa <- localhost 1111 sb <- localhost 2222 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ testOldHaProxyLocal6 :: Test testOldHaProxyLocal6 = testCase "test/old_ha_proxy_local6" $ do sa <- localhost6 1111 sb <- localhost6 2222 runInput "PROXY UNKNOWN\r\nblah" sa sb action where action proxyInfo !is !_ = do sa <- localhost6 1111 sb <- localhost6 2222 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET6 $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ testOldHaProxyFailure :: Test testOldHaProxyFailure = testCase "test/old_ha_proxy_failure" $ do sa <- localhost 1111 sb <- localhost 2222 expectException "bad family" $ runInput "PROXY ZZZ qqqq wwww 10000 80\r\nblah" sa sb action expectException "short" $ runInput "PROXY TCP4 \r\nblah" sa sb action expectException "non-integral" $ runInput "PROXY TCP4 127.0.0.1 127.0.0.1 xxx yyy\r\nblah" sa sb action where action _ _ _ = return () ------------------------------------------------------------------------------ testOldHaProxyBadAddress :: Test testOldHaProxyBadAddress = testCase "test/old_ha_proxy_bad_address" $ do sa <- localhost 1111 sb <- localhost 2222 expectException "bad address" $ runInput "PROXY TCP4 @~!@#$%^ (*^%$ 10000 80\r\nblah" sa sb action where action proxyInfo !is !_ = do sa <- localhost 10000 sb <- localhost 80 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ protocolHeader :: ByteString protocolHeader = S8.pack [ 0x0D, 0x0A, 0x0D, 0x0A, 0x00, 0x0D , 0x0A, 0x51, 0x55, 0x49, 0x54, 0x0A ] {-# NOINLINE protocolHeader #-} ------------------------------------------------------------------------------ testNewHaProxy :: Test testNewHaProxy = testCase "test/new_ha_proxy" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x21\x11" -- TCP over v4 , "\x00\x0c" -- 12 bytes of address (network ordered) , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] runInput input sa sb action where action proxyInfo !is !_ = do sa <- localhost 10000 sb <- localhost 80 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ #ifndef WINDOWS unixPath :: ByteString -> ByteString unixPath s = S.append s (S.replicate (108 - S.length s) '\x00') ------------------------------------------------------------------------------ unixSock :: ByteString -> N.SockAddr unixSock = N.SockAddrUnix . S.unpack ------------------------------------------------------------------------------ testNewHaProxyUnix :: Test testNewHaProxyUnix = testCase "test/new_ha_proxy_unix" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x21\x31" -- unix stream , "\x00\xd8" -- 216 bytes , unixPath "/foo" , unixPath "/bar" , "blah" -- the rest ] runInput input sa sb action let input2 = S.concat [ protocolHeader , "\x21\x32" -- unix datagram , "\x00\xd8" -- 216 bytes , unixPath "/foo" , unixPath "/bar" , "blah" -- the rest ] runInput input2 sa sb action2 where action proxyInfo !is !_ = do let sa = unixSock "/foo" let sb = unixSock "/bar" assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_UNIX $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] action2 proxyInfo !is !_ = do let sa = unixSock "/foo" let sb = unixSock "/bar" assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_UNIX $ HA.getFamily proxyInfo assertEqual "stype" N.Datagram $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] #endif ------------------------------------------------------------------------------ testNewHaProxy6 :: Test testNewHaProxy6 = testCase "test/new_ha_proxy_6" $ do sa <- localhost6 1111 sb <- localhost6 2222 let input = S.concat [ protocolHeader , "\x21\x21" -- TCP over v6 , "\x00\x24" -- 36 bytes of address (network ordered) , lhBinary , lhBinary , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] runInput input sa sb action where lhBinary = S.concat [ S.replicate 15 '\x00', S.singleton '\x01' ] action proxyInfo !is !_ = do sa <- localhost6 10000 sb <- localhost6 80 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET6 $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] ------------------------------------------------------------------------------ testNewHaProxyBadVersion :: Test testNewHaProxyBadVersion = testCase "test/new_ha_proxy_bad_version" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x31\x11" -- TCP over v4, bad version , "\x00\x0c" -- 12 bytes of address (network ordered) , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "bad version" $ runInput input sa sb action let input2 = S.concat [ protocolHeader , "\x2F\x11" -- TCP over v4, bad command , "\x00\x0c" -- 12 bytes of address (network ordered) , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "bad version" $ runInput input2 sa sb action let input3 = S.concat [ protocolHeader , "\x21\x41" -- bad family , "\x00\x0c" -- 12 bytes of address (network ordered) , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "bad family" $ runInput input3 sa sb action let input4 = S.concat [ protocolHeader , "\x21\x14" -- bad family , "\x00\x0c" -- 12 bytes of address (network ordered) , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "bad type" $ runInput input4 sa sb action where action _ !_ !_ = return () ------------------------------------------------------------------------------ testNewHaProxyTooSmall :: Test testNewHaProxyTooSmall = testCase "test/new_ha_proxy_too_small" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x21\x11" -- TCP over v4 , "\x00\x02" -- 2 bytes , "\x00\x00" , "blah" -- the rest ] expectException "too small" $ runInput input sa sb action let input2 = S.concat [ protocolHeader , "\x21\x21" -- TCP over v6 , "\x00\x02" -- 2 bytes , "\x00\x00" , "blah" -- the rest ] expectException "too small" $ runInput input2 sa sb action #ifndef WINDOWS let input3 = S.concat [ protocolHeader , "\x21\x31" -- unix , "\x00\x02" -- 2 bytes , "\x00\x00" , "blah" -- the rest ] expectException "too small" $ runInput input3 sa sb action #endif where action _ !_ !_ = return () ------------------------------------------------------------------------------ testNewHaProxyTooBig :: Test testNewHaProxyTooBig = testCase "test/new_ha_proxy_too_big" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x21\x11" -- TCP over v4 , "\x03\x0c" -- 780: 12 bytes of address -- (network ordered) plus 768 -- bytes of slop , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , S.replicate 768 '0' , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "too big" $ runInput input sa sb action let input2 = S.concat [ protocolHeader , "\x21\x00" -- TCP over v4 , "\x03\x0c" -- 780: 12 bytes of address -- (network ordered) plus 768 -- bytes of slop , "\x7f\x00\x00\x01" -- localhost , "\x7f\x00\x00\x01" , S.replicate 768 '0' , "\x27\x10" -- 10000 in network order , "\x00\x50" -- 80 in network order , "blah" -- the rest ] expectException "too big" $ runInput input2 sa sb action where action _ !_ !_ = return () ------------------------------------------------------------------------------ testNewHaProxyLocal :: Test testNewHaProxyLocal = testCase "test/new_ha_proxy_local" $ do sa <- localhost 1111 sb <- localhost 2222 let input = S.concat [ protocolHeader , "\x20\x00" -- LOCAL UNSPEC , "\x00\x00" -- 0 bytes of address (network ordered) , "blah" -- the rest ] runInput input sa sb action #ifndef WINDOWS let ua = unixSock "/foo" let ub = unixSock "/bar" let input2 = S.concat [ protocolHeader , "\x20\x00" -- LOCAL UNSPEC , "\x00\x00" -- 0 bytes of address (network ordered) , "blah" -- the rest ] runInput input2 ua ub action2 #endif where action proxyInfo !is !_ = do sa <- localhost 1111 sb <- localhost 2222 assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_INET $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] #ifndef WINDOWS action2 proxyInfo !is !_ = do let sa = unixSock "/foo" let sb = unixSock "/bar" assertEqual "src addr" sa $ HA.getSourceAddr proxyInfo assertEqual "dest addr" sb $ HA.getDestAddr proxyInfo assertEqual "family" N.AF_UNIX $ HA.getFamily proxyInfo assertEqual "stype" N.Stream $ HA.getSocketType proxyInfo Streams.toList is >>= assertEqual "rest" ["blah"] #endif ------------------------------------------------------------------------------ testGetSockAddr :: Test testGetSockAddr = testCase "test/address/getSockAddr" $ do (f1, a1) <- getSockAddr 10 "127.0.0.1" x1 <- localhost 10 assertEqual "f1" f1 N.AF_INET assertEqual "x1" x1 a1 (f2, a2) <- getSockAddr 10 "::1" x2 <- localhost6 10 assertEqual "f2" f2 N.AF_INET6 assertEqual "x2" x2 a2 expectException "empty result" $ getSockAddrImpl (\_ _ _ -> return []) 10 "foo" ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "test/trivials" $ do coverShowInstance $ HA.makeProxyInfo undefined undefined undefined undefined coverTypeableInstance $ AddressNotSupportedException undefined coverShowInstance $ AddressNotSupportedException "ok" ------------------------------------------------------------------------------ localhost :: Int -> IO (N.SockAddr) localhost p = N.SockAddrInet (fromIntegral p) <$> N.inet_addr "127.0.0.1" ------------------------------------------------------------------------------ localhost6 :: Int -> IO (N.SockAddr) localhost6 p = snd <$> getSockAddr p "::1" ------------------------------------------------------------------------------ expectException :: String -> IO a -> IO () expectException name act = do e <- E.try act case e of Left (z::E.SomeException) -> (length $ show z) `seq` return () Right _ -> fail $ name ++ ": expected exception, didn't get one" ------------------------------------------------------------------------------ coverTypeableInstance :: (Monad m, Typeable a) => a -> m () coverTypeableInstance a = typeOf a `seq` return () ------------------------------------------------------------------------------ eatException :: IO a -> IO () eatException a = (a >> return ()) `E.catch` handler where handler :: E.SomeException -> IO () handler _ = return () ------------------------------------------------------------------------------ -- | Kill the false negative on derived show instances. coverShowInstance :: (MonadIO m, Show a) => a -> m () coverShowInstance x = liftIO (a >> b >> c) where a = eatException $ E.evaluate $ length $ showsPrec 0 x "" b = eatException $ E.evaluate $ length $ show x c = eatException $ E.evaluate $ length $ showList [x] ""