io-streams-haproxy (empty) → 1.0.0.0
raw patch · 9 files changed
+1169/−0 lines, 9 filesdep +HUnitdep +attoparsecdep +basesetup-changed
Dependencies added: HUnit, attoparsec, base, bytestring, io-streams, network, test-framework, test-framework-hunit, transformers
Files
- CONTRIBUTORS +6/−0
- LICENSE +28/−0
- Setup.hs +2/−0
- cbits/byteorder.c +21/−0
- io-streams-haproxy.cabal +72/−0
- src/System/IO/Streams/Network/HAProxy.hs +361/−0
- src/System/IO/Streams/Network/Internal/Address.hs +50/−0
- test/System/IO/Streams/Network/HAProxy/Tests.hs +618/−0
- test/TestSuite.hs +11/−0
+ CONTRIBUTORS view
@@ -0,0 +1,6 @@+------------------------------------------------------------------------------+Contributors to io-streams-haproxy:++ - Gregory Collins <greg@gregorycollins.net>++------------------------------------------------------------------------------
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/byteorder.c view
@@ -0,0 +1,21 @@+/* Sigh. According to the docs for <arpa/inet.h>, htonl() and friends may be+ implemented as macros only, so I have to re-export functions here to do the+ conversions. */++#include <arpa/inet.h>++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.cabal view
@@ -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+ <http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt>) 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
+ src/System/IO/Streams/Network/HAProxy.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TupleSections #-}++{-|++HAProxy proxying protocol support (see+<http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt>) 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"
+ src/System/IO/Streams/Network/Internal/Address.hs view
@@ -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] }
+ test/System/IO/Streams/Network/HAProxy/Tests.hs view
@@ -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] ""
+ test/TestSuite.hs view
@@ -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 ]