{-# 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 :: Socket -> SockAddr -> IO ProxyInfo
socketToProxyInfo Socket
s SockAddr
sa = do
    da <- Socket -> IO SockAddr
N.getSocketName Socket
s
    !sty <- getSockType
    return $! makeProxyInfo sa da (addrFamily sa) sty
  where
#if MIN_VERSION_network(3,0,1)
    getSockType :: IO SocketType
getSockType = Socket -> IO SocketType
N.getSocketType Socket
s
#else
    getSockType = let (N.MkSocket _ _ sty _ _) = s in return sty
#endif

------------------------------------------------------------------------------
-- | 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 :: forall a.
Socket
-> SockAddr
-> (ProxyInfo
    -> InputStream ByteString -> OutputStream ByteString -> IO a)
-> IO a
behindHAProxy Socket
socket SockAddr
sa ProxyInfo
-> InputStream ByteString -> OutputStream ByteString -> IO a
m = do
    pinfo    <- Socket -> SockAddr -> IO ProxyInfo
socketToProxyInfo Socket
socket SockAddr
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 :: forall a.
ProxyInfo
-> (InputStream ByteString, OutputStream ByteString)
-> (ProxyInfo
    -> InputStream ByteString -> OutputStream ByteString -> IO a)
-> IO a
behindHAProxyWithLocalInfo ProxyInfo
localProxyInfo (InputStream ByteString
is, OutputStream ByteString
os) ProxyInfo
-> InputStream ByteString -> OutputStream ByteString -> IO a
m = do
    proxyInfo <- ProxyInfo -> InputStream ByteString -> IO ProxyInfo
decodeHAProxyHeaders ProxyInfo
localProxyInfo InputStream ByteString
is
    m proxyInfo is os


------------------------------------------------------------------------------
decodeHAProxyHeaders :: ProxyInfo -> (InputStream ByteString) -> IO ProxyInfo
decodeHAProxyHeaders :: ProxyInfo -> InputStream ByteString -> IO ProxyInfo
decodeHAProxyHeaders ProxyInfo
localProxyInfo InputStream ByteString
is0 = do
    -- 536 bytes as per spec
    is <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
536 InputStream ByteString
is0
    (!isOld, !mbOldInfo) <- Streams.parseFromStream
                              (((True,) <$> parseOldHaProxy)
                               <|> return (False, Nothing)) is
    if isOld
      then maybe (return localProxyInfo)
                 (\(ByteString
srcAddr, Int
srcPort, ByteString
destAddr, Int
destPort, Family
f) -> do
                     (_, s) <- Int -> ByteString -> IO (Family, SockAddr)
getSockAddr Int
srcPort ByteString
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 {
      ProxyInfo -> SockAddr
_sourceAddr :: N.SockAddr
    , ProxyInfo -> SockAddr
_destAddr   :: N.SockAddr
    , ProxyInfo -> Family
_family     :: N.Family
    , ProxyInfo -> SocketType
_sockType   :: N.SocketType
    } deriving (Int -> ProxyInfo -> ShowS
[ProxyInfo] -> ShowS
ProxyInfo -> [Char]
(Int -> ProxyInfo -> ShowS)
-> (ProxyInfo -> [Char])
-> ([ProxyInfo] -> ShowS)
-> Show ProxyInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProxyInfo -> ShowS
showsPrec :: Int -> ProxyInfo -> ShowS
$cshow :: ProxyInfo -> [Char]
show :: ProxyInfo -> [Char]
$cshowList :: [ProxyInfo] -> ShowS
showList :: [ProxyInfo] -> ShowS
Show)


------------------------------------------------------------------------------
-- | Gets the 'N.Family' of the proxied request (i.e. IPv4/IPv6/Unix domain
-- sockets).
getFamily :: ProxyInfo -> N.Family
getFamily :: ProxyInfo -> Family
getFamily ProxyInfo
p = ProxyInfo -> Family
_family ProxyInfo
p


------------------------------------------------------------------------------
-- | Gets the 'N.SocketType' of the proxied request (UDP/TCP).
getSocketType :: ProxyInfo -> N.SocketType
getSocketType :: ProxyInfo -> SocketType
getSocketType ProxyInfo
p = ProxyInfo -> SocketType
_sockType ProxyInfo
p


------------------------------------------------------------------------------
-- | Gets the network address of the source node for this request (i.e. the
-- client).
getSourceAddr :: ProxyInfo -> N.SockAddr
getSourceAddr :: ProxyInfo -> SockAddr
getSourceAddr ProxyInfo
p = ProxyInfo -> SockAddr
_sourceAddr ProxyInfo
p


------------------------------------------------------------------------------
-- | Gets the network address of the destination node for this request (i.e. the
-- client).
getDestAddr :: ProxyInfo -> N.SockAddr
getDestAddr :: ProxyInfo -> SockAddr
getDestAddr ProxyInfo
p = ProxyInfo -> SockAddr
_destAddr ProxyInfo
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 :: SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
srcAddr SockAddr
destAddr Family
f SocketType
st = SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
ProxyInfo SockAddr
srcAddr SockAddr
destAddr Family
f SocketType
st


------------------------------------------------------------------------------
parseFamily :: Parser (Maybe N.Family)
parseFamily :: Parser (Maybe Family)
parseFamily = (ByteString -> Parser ByteString
string ByteString
"TCP4" Parser ByteString -> Parser (Maybe Family) -> Parser (Maybe Family)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Family -> Maybe Family
forall a. a -> Maybe a
Just Family
N.AF_INET))
                Parser (Maybe Family)
-> Parser (Maybe Family) -> Parser (Maybe Family)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
string ByteString
"TCP6" Parser ByteString -> Parser (Maybe Family) -> Parser (Maybe Family)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Family -> Maybe Family
forall a. a -> Maybe a
Just Family
N.AF_INET6))
                Parser (Maybe Family)
-> Parser (Maybe Family) -> Parser (Maybe Family)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
string ByteString
"UNKNOWN" Parser ByteString -> Parser (Maybe Family) -> Parser (Maybe Family)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Family
forall a. Maybe a
Nothing)


------------------------------------------------------------------------------
parseOldHaProxy :: Parser (Maybe (ByteString, Int, ByteString, Int, N.Family))
parseOldHaProxy :: Parser
  ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
parseOldHaProxy = do
    ByteString -> Parser ByteString
string ByteString
"PROXY "
    gotFamily <- Parser (Maybe Family)
parseFamily
    case gotFamily of
      Maybe Family
Nothing  -> (Char -> Bool) -> Parser ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Parser () -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Parser ByteString
string ByteString
"\r\n" Parser ByteString
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (ByteString, Int, ByteString, Int, Family)
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, Int, ByteString, Int, Family)
forall a. Maybe a
Nothing
      (Just Family
f) -> do
          Char -> Parser Char
char Char
' '
          srcAddress <- (Char -> Bool) -> Parser ByteString
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
          char ' '
          destAddress <- takeWhile1 (/= ' ')
          char ' '
          srcPort <- decimal
          char ' '
          destPort <- decimal
          string "\r\n"
          return $! Just $! (srcAddress, srcPort, destAddress, destPort, f)


------------------------------------------------------------------------------
protocolHeader :: ByteString
protocolHeader :: ByteString
protocolHeader = [Word8] -> ByteString
S8.pack [ Word8
0x0D, Word8
0x0A, Word8
0x0D, Word8
0x0A, Word8
0x00, Word8
0x0D
                         , Word8
0x0A, Word8
0x51, Word8
0x55, Word8
0x49, Word8
0x54, Word8
0x0A ]
{-# NOINLINE protocolHeader #-}


------------------------------------------------------------------------------
parseNewHaProxy :: ProxyInfo -> Parser ProxyInfo
parseNewHaProxy :: ProxyInfo -> Parser ProxyInfo
parseNewHaProxy ProxyInfo
localProxyInfo = do
    ByteString -> Parser ByteString
string ByteString
protocolHeader

    versionAndCommand <- Parser Word8
anyWord8
    let version = (Word8
versionAndCommand Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF0) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4
    let command = (Word8
versionAndCommand Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF) :: Word8

    when (version /= 0x2) $ fail $ "Invalid protocol version: " ++ show version
    when (command > 1) $ fail $ "Invalid command: " ++ show command

    protocolAndFamily <- anyWord8
    let family = (Word8
protocolAndFamily Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF0) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4
    let protocol = (Word8
protocolAndFamily Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
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
        !()
_ | Word8
command Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0 Bool -> Bool -> Bool
|| Word8
family Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0 Bool -> Bool -> Bool
|| Word8
protocol Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0   -- LOCAL
                -> Word16 -> Parser ProxyInfo
forall {a}. (Show a, Integral a) => a -> Parser ProxyInfo
handleLocal Word16
addressLen
           | Word8
family Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x1 -> Word16 -> SocketType -> Parser ProxyInfo
forall {a}.
(Show a, Integral a) =>
a -> SocketType -> Parser ProxyInfo
handleIPv4 Word16
addressLen SocketType
socketType
           | Word8
family Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x2 -> Word16 -> SocketType -> Parser ProxyInfo
forall {a}.
(Show a, Integral a) =>
a -> SocketType -> Parser ProxyInfo
handleIPv6 Word16
addressLen SocketType
socketType
#ifndef WINDOWS
           | Word8
family Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3 -> Word16 -> SocketType -> Parser ProxyInfo
forall {a}.
(Show a, Integral a) =>
a -> SocketType -> Parser ProxyInfo
handleUnix Word16
addressLen SocketType
socketType
#endif
           | Bool
otherwise     -> [Char] -> Parser ProxyInfo
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ProxyInfo) -> [Char] -> Parser ProxyInfo
forall a b. (a -> b) -> a -> b
$ [Char]
"Bad family " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
family

  where
    toSocketType :: a -> m SocketType
toSocketType a
0 = SocketType -> m SocketType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SocketType -> m SocketType) -> SocketType -> m SocketType
forall a b. (a -> b) -> a -> b
$! SocketType
N.Stream
    toSocketType a
1 = SocketType -> m SocketType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SocketType -> m SocketType) -> SocketType -> m SocketType
forall a b. (a -> b) -> a -> b
$! SocketType
N.Stream
    toSocketType a
2 = SocketType -> m SocketType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SocketType -> m SocketType) -> SocketType -> m SocketType
forall a b. (a -> b) -> a -> b
$! SocketType
N.Datagram
    toSocketType a
_ = [Char] -> m SocketType
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"bad protocol"

    handleLocal :: a -> Parser ProxyInfo
handleLocal a
addressLen = do
        -- skip N bytes and return the original addresses
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
addressLen a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
500) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"suspiciously long address "
                                          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
        Parser ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString -> Parser ()) -> Parser ByteString -> Parser ()
forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
take (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
addressLen)
        ProxyInfo -> Parser ProxyInfo
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ProxyInfo
localProxyInfo

    handleIPv4 :: a -> SocketType -> Parser ProxyInfo
handleIPv4 a
addressLen SocketType
socketType = do
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
addressLen a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
12) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for IPv4"
        let nskip :: a
nskip = a
addressLen a -> a -> a
forall a. Num a => a -> a -> a
- a
12
        srcAddr  <- Parser Word32
snarf32
        destAddr <- snarf32
        srcPort  <- ntohs <$> snarf16
        destPort <- ntohs <$> snarf16
        void $ take $ fromIntegral nskip

        -- Note: we actually want the brain-dead constructors here
        let sa = PortNumber -> Word32 -> SockAddr
N.SockAddrInet (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
srcPort) Word32
srcAddr
        let sb = PortNumber -> Word32 -> SockAddr
N.SockAddrInet (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
destPort) Word32
destAddr
        return $! makeProxyInfo sa sb (addrFamily sa) socketType

    handleIPv6 :: a -> SocketType -> Parser ProxyInfo
handleIPv6 a
addressLen SocketType
socketType = do
        let scopeId :: Word32
scopeId = Word32
0   -- means "reserved", kludge alert!
        let flow :: Word32
flow    = Word32
0

        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
addressLen a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
36) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for IPv6"
        let nskip :: a
nskip = a
addressLen a -> a -> a
forall a. Num a => a -> a -> a
- a
36
        s1 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
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 = PortNumber -> Word32 -> HostAddress6 -> Word32 -> SockAddr
N.SockAddrInet6 (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
sp) Word32
flow (Word32
s1, Word32
s2, Word32
s3, Word32
s4) Word32
scopeId
        let sb = PortNumber -> Word32 -> HostAddress6 -> Word32 -> SockAddr
N.SockAddrInet6 (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dp) Word32
flow (Word32
d1, Word32
d2, Word32
d3, Word32
d4) Word32
scopeId

        return $! makeProxyInfo sa sb (addrFamily sa) socketType
#ifndef WINDOWS
    handleUnix :: a -> SocketType -> Parser ProxyInfo
handleUnix a
addressLen SocketType
socketType = do
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
addressLen a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
216) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for unix"
        addr1 <- Int -> Parser ByteString
take Int
108
        addr2 <- take 108
        void $ take $ fromIntegral $ addressLen - 216
        let sa = [Char] -> SockAddr
N.SockAddrUnix (ByteString -> [Char]
toUnixPath ByteString
addr1)
        let sb = [Char] -> SockAddr
N.SockAddrUnix (ByteString -> [Char]
toUnixPath ByteString
addr2)
        return $! makeProxyInfo sa sb (addrFamily sa) socketType

    toUnixPath :: ByteString -> [Char]
toUnixPath = ByteString -> [Char]
S.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\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 :: Word16 -> Word16
ntohs = CUShort -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUShort -> Word16) -> (Word16 -> CUShort) -> Word16 -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CUShort -> CUShort
c_ntohs (CUShort -> CUShort) -> (Word16 -> CUShort) -> Word16 -> CUShort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> CUShort
forall a b. (Integral a, Num b) => a -> b
fromIntegral

ntohl :: Word32 -> Word32
ntohl :: Word32 -> Word32
ntohl = CUInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Word32) -> (Word32 -> CUInt) -> Word32 -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CUInt -> CUInt
c_ntohl (CUInt -> CUInt) -> (Word32 -> CUInt) -> Word32 -> CUInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral

snarf32 :: Parser Word32
snarf32 :: Parser Word32
snarf32 = do
    s <- Int -> Parser ByteString
take Int
4
    return $! unsafePerformIO $! S.unsafeUseAsCString s $ peek . castPtr


snarf16 :: Parser Word16
snarf16 :: Parser ByteString Word16
snarf16 = do
    s <- Int -> Parser ByteString
take Int
2
    return $! unsafePerformIO $! S.unsafeUseAsCString s $ peek . castPtr

addrFamily :: N.SockAddr -> N.Family
addrFamily :: SockAddr -> Family
addrFamily SockAddr
s = case SockAddr
s of
                 (N.SockAddrInet PortNumber
_ Word32
_)      -> Family
N.AF_INET
                 (N.SockAddrInet6 PortNumber
_ Word32
_ HostAddress6
_ Word32
_) -> Family
N.AF_INET6
#ifndef WINDOWS
                 (N.SockAddrUnix [Char]
_ )       -> Family
N.AF_UNIX
#endif
                 SockAddr
_                         -> [Char] -> Family
forall a. HasCallStack => [Char] -> a
error [Char]
"unknown family"