{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
module System.IO.Streams.Network.HAProxy
(
behindHAProxy
, behindHAProxyWithLocalInfo
, decodeHAProxyHeaders
, 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
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
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
behindHAProxy :: N.Socket
-> N.SockAddr
-> (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
behindHAProxyWithLocalInfo
:: ProxyInfo
-> (InputStream ByteString, OutputStream ByteString)
-> (ProxyInfo
-> InputStream ByteString
-> OutputStream ByteString
-> IO a)
-> 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
ProxyInfo
localProxyInfo InputStream ByteString
is0 = do
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
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)
getFamily :: ProxyInfo -> N.Family
getFamily :: ProxyInfo -> Family
getFamily ProxyInfo
p = ProxyInfo -> Family
_family ProxyInfo
p
getSocketType :: ProxyInfo -> N.SocketType
getSocketType :: ProxyInfo -> SocketType
getSocketType ProxyInfo
p = ProxyInfo -> SocketType
_sockType ProxyInfo
p
getSourceAddr :: ProxyInfo -> N.SockAddr
getSourceAddr :: ProxyInfo -> SockAddr
getSourceAddr ProxyInfo
p = ProxyInfo -> SockAddr
_sourceAddr ProxyInfo
p
getDestAddr :: ProxyInfo -> N.SockAddr
getDestAddr :: ProxyInfo -> SockAddr
getDestAddr ProxyInfo
p = ProxyInfo -> SockAddr
_destAddr ProxyInfo
p
makeProxyInfo :: N.SockAddr
-> N.SockAddr
-> N.Family
-> N.SocketType
-> 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
= [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
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
-> 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
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
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
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"