{-# 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
    SockAddr
da <- Socket -> IO SockAddr
N.getSocketName Socket
s
    !SocketType
sty <- IO SocketType
getSockType
    ProxyInfo -> IO ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProxyInfo -> IO ProxyInfo) -> ProxyInfo -> IO ProxyInfo
forall a b. (a -> b) -> a -> b
$! SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
sa SockAddr
da (SockAddr -> Family
addrFamily SockAddr
sa) SocketType
sty
  where
#if MIN_VERSION_network(2,7,0)
    getSockType :: IO SocketType
getSockType = do
        Int
c <- Socket -> SocketOption -> IO Int
N.getSocketOption Socket
s SocketOption
N.Type
        -- This is a kludge until network has better support for returning
        -- SocketType
        case Int
c of
          Int
1 -> SocketType -> IO SocketType
forall (m :: * -> *) a. Monad m => a -> m a
return SocketType
N.Stream
          Int
2 -> SocketType -> IO SocketType
forall (m :: * -> *) a. Monad m => a -> m a
return SocketType
N.Datagram
          Int
_ -> [Char] -> IO SocketType
forall a. HasCallStack => [Char] -> a
error ([Char]
"bad socket type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c)
#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 :: 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
    ProxyInfo
pinfo    <- Socket -> SockAddr -> IO ProxyInfo
socketToProxyInfo Socket
socket SockAddr
sa
    (InputStream ByteString, OutputStream ByteString)
sockets  <- Socket -> IO (InputStream ByteString, OutputStream ByteString)
Streams.socketToStreams Socket
socket
    ProxyInfo
-> (InputStream ByteString, OutputStream ByteString)
-> (ProxyInfo
    -> InputStream ByteString -> OutputStream ByteString -> IO a)
-> IO a
forall a.
ProxyInfo
-> (InputStream ByteString, OutputStream ByteString)
-> (ProxyInfo
    -> InputStream ByteString -> OutputStream ByteString -> IO a)
-> IO a
behindHAProxyWithLocalInfo ProxyInfo
pinfo (InputStream ByteString, OutputStream ByteString)
sockets ProxyInfo
-> InputStream ByteString -> OutputStream ByteString -> IO a
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 :: 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 <- ProxyInfo -> InputStream ByteString -> IO ProxyInfo
decodeHAProxyHeaders ProxyInfo
localProxyInfo InputStream ByteString
is
    ProxyInfo
-> InputStream ByteString -> OutputStream ByteString -> IO a
m ProxyInfo
proxyInfo InputStream ByteString
is OutputStream ByteString
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
    InputStream ByteString
is <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
536 InputStream ByteString
is0
    (!Bool
isOld, !Maybe (ByteString, Int, ByteString, Int, Family)
mbOldInfo) <- Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
-> InputStream ByteString
-> IO (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream
                              (((Bool
True,) (Maybe (ByteString, Int, ByteString, Int, Family)
 -> (Bool, Maybe (ByteString, Int, ByteString, Int, Family)))
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
-> Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser
  ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
parseOldHaProxy)
                               Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
-> Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
-> Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
-> Parser (Bool, Maybe (ByteString, Int, ByteString, Int, Family))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Maybe (ByteString, Int, ByteString, Int, Family)
forall a. Maybe a
Nothing)) InputStream ByteString
is
    if Bool
isOld
      then IO ProxyInfo
-> ((ByteString, Int, ByteString, Int, Family) -> IO ProxyInfo)
-> Maybe (ByteString, Int, ByteString, Int, Family)
-> IO ProxyInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProxyInfo -> IO ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ProxyInfo
localProxyInfo)
                 (\(ByteString
srcAddr, Int
srcPort, ByteString
destAddr, Int
destPort, Family
f) -> do
                     (Family
_, SockAddr
s) <- Int -> ByteString -> IO (Family, SockAddr)
getSockAddr Int
srcPort ByteString
srcAddr
                     (Family
_, SockAddr
d) <- Int -> ByteString -> IO (Family, SockAddr)
getSockAddr Int
destPort ByteString
destAddr
                     ProxyInfo -> IO ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProxyInfo -> IO ProxyInfo) -> ProxyInfo -> IO ProxyInfo
forall a b. (a -> b) -> a -> b
$! SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
s SockAddr
d Family
f (SocketType -> ProxyInfo) -> SocketType -> ProxyInfo
forall a b. (a -> b) -> a -> b
$ ProxyInfo -> SocketType
getSocketType ProxyInfo
localProxyInfo)
                 Maybe (ByteString, Int, ByteString, Int, Family)
mbOldInfo
      else Parser ProxyInfo -> InputStream ByteString -> IO ProxyInfo
forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream (ProxyInfo -> Parser ProxyInfo
parseNewHaProxy ProxyInfo
localProxyInfo) InputStream ByteString
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 -> [Char] -> [Char]
[ProxyInfo] -> [Char] -> [Char]
ProxyInfo -> [Char]
(Int -> ProxyInfo -> [Char] -> [Char])
-> (ProxyInfo -> [Char])
-> ([ProxyInfo] -> [Char] -> [Char])
-> Show ProxyInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ProxyInfo] -> [Char] -> [Char]
$cshowList :: [ProxyInfo] -> [Char] -> [Char]
show :: ProxyInfo -> [Char]
$cshow :: ProxyInfo -> [Char]
showsPrec :: Int -> ProxyInfo -> [Char] -> [Char]
$cshowsPrec :: Int -> ProxyInfo -> [Char] -> [Char]
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Family -> Parser (Maybe Family)
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 "
    Maybe Family
gotFamily <- Parser (Maybe Family)
parseFamily
    case Maybe Family
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 (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 (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 (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
' '
          ByteString
srcAddress <- (Char -> Bool) -> Parser ByteString
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
          Char -> Parser Char
char Char
' '
          ByteString
destAddress <- (Char -> Bool) -> Parser ByteString
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
          Char -> Parser Char
char Char
' '
          Int
srcPort <- Parser Int
forall a. Integral a => Parser a
decimal
          Char -> Parser Char
char Char
' '
          Int
destPort <- Parser Int
forall a. Integral a => Parser a
decimal
          ByteString -> Parser ByteString
string ByteString
"\r\n"
          Maybe (ByteString, Int, ByteString, Int, Family)
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, Int, ByteString, Int, Family)
 -> Parser
      ByteString (Maybe (ByteString, Int, ByteString, Int, Family)))
-> Maybe (ByteString, Int, ByteString, Int, Family)
-> Parser
     ByteString (Maybe (ByteString, Int, ByteString, Int, Family))
forall a b. (a -> b) -> a -> b
$! (ByteString, Int, ByteString, Int, Family)
-> Maybe (ByteString, Int, ByteString, Int, Family)
forall a. a -> Maybe a
Just ((ByteString, Int, ByteString, Int, Family)
 -> Maybe (ByteString, Int, ByteString, Int, Family))
-> (ByteString, Int, ByteString, Int, Family)
-> Maybe (ByteString, Int, ByteString, Int, Family)
forall a b. (a -> b) -> a -> b
$! (ByteString
srcAddress, Int
srcPort, ByteString
destAddress, Int
destPort, Family
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

    Word8
versionAndCommand <- Parser Word8
anyWord8
    let version :: Word8
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
command = (Word8
versionAndCommand Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF) :: Word8

    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x2) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid protocol version: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
version
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
command Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
1) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid command: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
command

    Word8
protocolAndFamily <- Parser Word8
anyWord8
    let family :: Word8
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
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
socketType <- Word8 -> Parser ByteString SocketType
forall a (m :: * -> *).
(Eq a, Num a, MonadFail m) =>
a -> m SocketType
toSocketType Word8
protocol

    Word16
addressLen <- Word16 -> Word16
ntohs (Word16 -> Word16)
-> Parser ByteString Word16 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
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 (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] -> [Char] -> [Char]
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 (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 (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 (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 (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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"suspiciously long address "
                                          [Char] -> [Char] -> [Char]
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 (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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> [Char] -> [Char]
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
        Word32
srcAddr  <- Parser Word32
snarf32
        Word32
destAddr <- Parser Word32
snarf32
        Word16
srcPort  <- Word16 -> Word16
ntohs (Word16 -> Word16)
-> Parser ByteString Word16 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
snarf16
        Word16
destPort <- Word16 -> Word16
ntohs (Word16 -> Word16)
-> Parser ByteString Word16 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
snarf16
        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 (Int -> Parser ByteString) -> Int -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nskip

        -- Note: we actually want the brain-dead constructors here
        let sa :: SockAddr
sa = PortNumber -> Word32 -> SockAddr
N.SockAddrInet (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
srcPort) Word32
srcAddr
        let sb :: SockAddr
sb = PortNumber -> Word32 -> SockAddr
N.SockAddrInet (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
destPort) Word32
destAddr
        ProxyInfo -> Parser ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProxyInfo -> Parser ProxyInfo) -> ProxyInfo -> Parser ProxyInfo
forall a b. (a -> b) -> a -> b
$! SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
sa SockAddr
sb (SockAddr -> Family
addrFamily SockAddr
sa) SocketType
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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> [Char] -> [Char]
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
        Word32
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
        Word32
s2 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32
        Word32
s3 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32
        Word32
s4 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32

        Word32
d1 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32
        Word32
d2 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32
        Word32
d3 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32
        Word32
d4 <- Word32 -> Word32
ntohl (Word32 -> Word32) -> Parser Word32 -> Parser Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
snarf32

        Word16
sp <- Word16 -> Word16
ntohs (Word16 -> Word16)
-> Parser ByteString Word16 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
snarf16
        Word16
dp <- Word16 -> Word16
ntohs (Word16 -> Word16)
-> Parser ByteString Word16 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
snarf16

        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 (Int -> Parser ByteString) -> Int -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nskip

        let sa :: SockAddr
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 :: SockAddr
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

        ProxyInfo -> Parser ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProxyInfo -> Parser ProxyInfo) -> ProxyInfo -> Parser ProxyInfo
forall a b. (a -> b) -> a -> b
$! SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
sa SockAddr
sb (SockAddr -> Family
addrFamily SockAddr
sa) SocketType
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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"bad address length "
                                         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
addressLen
                                         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for unix"
        ByteString
addr1 <- Int -> Parser ByteString
take Int
108
        ByteString
addr2 <- Int -> Parser ByteString
take Int
108
        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 (Int -> Parser ByteString) -> Int -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ a
addressLen a -> a -> a
forall a. Num a => a -> a -> a
- a
216
        let sa :: SockAddr
sa = [Char] -> SockAddr
N.SockAddrUnix (ByteString -> [Char]
toUnixPath ByteString
addr1)
        let sb :: SockAddr
sb = [Char] -> SockAddr
N.SockAddrUnix (ByteString -> [Char]
toUnixPath ByteString
addr2)
        ProxyInfo -> Parser ProxyInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProxyInfo -> Parser ProxyInfo) -> ProxyInfo -> Parser ProxyInfo
forall a b. (a -> b) -> a -> b
$! SockAddr -> SockAddr -> Family -> SocketType -> ProxyInfo
makeProxyInfo SockAddr
sa SockAddr
sb (SockAddr -> Family
addrFamily SockAddr
sa) SocketType
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
    ByteString
s <- Int -> Parser ByteString
take Int
4
    Word32 -> Parser Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Parser Word32) -> Word32 -> Parser Word32
forall a b. (a -> b) -> a -> b
$! IO Word32 -> Word32
forall a. IO a -> a
unsafePerformIO (IO Word32 -> Word32) -> IO Word32 -> Word32
forall a b. (a -> b) -> a -> b
$! ByteString -> (CString -> IO Word32) -> IO Word32
forall a. ByteString -> (CString -> IO a) -> IO a
S.unsafeUseAsCString ByteString
s ((CString -> IO Word32) -> IO Word32)
-> (CString -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word32 -> IO Word32)
-> (CString -> Ptr Word32) -> CString -> IO Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr


snarf16 :: Parser Word16
snarf16 :: Parser ByteString Word16
snarf16 = do
    ByteString
s <- Int -> Parser ByteString
take Int
2
    Word16 -> Parser ByteString Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Parser ByteString Word16)
-> Word16 -> Parser ByteString Word16
forall a b. (a -> b) -> a -> b
$! IO Word16 -> Word16
forall a. IO a -> a
unsafePerformIO (IO Word16 -> Word16) -> IO Word16 -> Word16
forall a b. (a -> b) -> a -> b
$! ByteString -> (CString -> IO Word16) -> IO Word16
forall a. ByteString -> (CString -> IO a) -> IO a
S.unsafeUseAsCString ByteString
s ((CString -> IO Word16) -> IO Word16)
-> (CString -> IO Word16) -> IO Word16
forall a b. (a -> b) -> a -> b
$ Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word16 -> IO Word16)
-> (CString -> Ptr Word16) -> CString -> IO Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr Word16
forall a b. Ptr a -> Ptr b
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"