diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,6 @@ +------------------------------------------------------------------------------ +Contributors to io-streams-haproxy: + + - Gregory Collins + +------------------------------------------------------------------------------ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/byteorder.c b/cbits/byteorder.c new file mode 100644 --- /dev/null +++ b/cbits/byteorder.c @@ -0,0 +1,21 @@ +/* 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. */ + +#include + +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); +} diff --git a/io-streams-haproxy.cabal b/io-streams-haproxy.cabal new file mode 100644 --- /dev/null +++ b/io-streams-haproxy.cabal @@ -0,0 +1,72 @@ +name: io-streams-haproxy +version: 1.0.0.0 +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.4 && < 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 + +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 diff --git a/src/System/IO/Streams/Network/HAProxy.hs b/src/System/IO/Streams/Network/HAProxy.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Network/HAProxy.hs @@ -0,0 +1,361 @@ +{-# 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" diff --git a/src/System/IO/Streams/Network/Internal/Address.hs b/src/System/IO/Streams/Network/Internal/Address.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Network/Internal/Address.hs @@ -0,0 +1,50 @@ +{-# 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] } diff --git a/test/System/IO/Streams/Network/HAProxy/Tests.hs b/test/System/IO/Streams/Network/HAProxy/Tests.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Network/HAProxy/Tests.hs @@ -0,0 +1,618 @@ +{-# 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] "" diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,11 @@ +module 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 ]