{- |
Module      : Network.Socks5.Wire
License     : BSD-style
Copyright   : (c) 2010-2019 Vincent Hanquez <vincent@snarc.org>
Stability   : experimental
Portability : unknown
-}

module Network.Socks5.Wire
  ( SocksHello (..)
  , SocksHelloResponse (..)
  , SocksRequest (..)
  , SocksResponse (..)
  ) where

import           Control.Monad ( liftM4, replicateM )
import qualified Data.ByteString as B
import           Data.Serialize
                   ( Get, Put, PutM (..), Serialize (..), getByteString
                   , getWord16be, getWord32host, getWord8, putByteString
                   , putWord16be, putWord32host, putWord8
                   )
import           Network.Socket ( PortNumber )
import           Network.Socks5.Types
                   ( SocksCommand, SocksHostAddress (..), SocksMethod
                   , SocksReply
                   )

-- | Type representing initial messages sent by a client with the list of

-- authentification methods supported.

newtype SocksHello = SocksHello
  { SocksHello -> [SocksMethod]
getSocksHelloMethods :: [SocksMethod]
  }
  deriving (SocksHello -> SocksHello -> Bool
(SocksHello -> SocksHello -> Bool)
-> (SocksHello -> SocksHello -> Bool) -> Eq SocksHello
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksHello -> SocksHello -> Bool
== :: SocksHello -> SocksHello -> Bool
$c/= :: SocksHello -> SocksHello -> Bool
/= :: SocksHello -> SocksHello -> Bool
Eq, Int -> SocksHello -> ShowS
[SocksHello] -> ShowS
SocksHello -> String
(Int -> SocksHello -> ShowS)
-> (SocksHello -> String)
-> ([SocksHello] -> ShowS)
-> Show SocksHello
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksHello -> ShowS
showsPrec :: Int -> SocksHello -> ShowS
$cshow :: SocksHello -> String
show :: SocksHello -> String
$cshowList :: [SocksHello] -> ShowS
showList :: [SocksHello] -> ShowS
Show)

-- | Type representing initial messages sent by a server in response to Hello,

-- with the server's chosen method of authentication.

newtype SocksHelloResponse = SocksHelloResponse
  { SocksHelloResponse -> SocksMethod
getSocksHelloResponseMethod :: SocksMethod
  }
  deriving (SocksHelloResponse -> SocksHelloResponse -> Bool
(SocksHelloResponse -> SocksHelloResponse -> Bool)
-> (SocksHelloResponse -> SocksHelloResponse -> Bool)
-> Eq SocksHelloResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksHelloResponse -> SocksHelloResponse -> Bool
== :: SocksHelloResponse -> SocksHelloResponse -> Bool
$c/= :: SocksHelloResponse -> SocksHelloResponse -> Bool
/= :: SocksHelloResponse -> SocksHelloResponse -> Bool
Eq, Int -> SocksHelloResponse -> ShowS
[SocksHelloResponse] -> ShowS
SocksHelloResponse -> String
(Int -> SocksHelloResponse -> ShowS)
-> (SocksHelloResponse -> String)
-> ([SocksHelloResponse] -> ShowS)
-> Show SocksHelloResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksHelloResponse -> ShowS
showsPrec :: Int -> SocksHelloResponse -> ShowS
$cshow :: SocksHelloResponse -> String
show :: SocksHelloResponse -> String
$cshowList :: [SocksHelloResponse] -> ShowS
showList :: [SocksHelloResponse] -> ShowS
Show)

-- | Type representing SOCKS requests.

data SocksRequest = SocksRequest
  { SocksRequest -> SocksCommand
requestCommand :: SocksCommand
  , SocksRequest -> SocksHostAddress
requestDstAddr :: SocksHostAddress
  , SocksRequest -> PortNumber
requestDstPort :: PortNumber
  }
  deriving (SocksRequest -> SocksRequest -> Bool
(SocksRequest -> SocksRequest -> Bool)
-> (SocksRequest -> SocksRequest -> Bool) -> Eq SocksRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksRequest -> SocksRequest -> Bool
== :: SocksRequest -> SocksRequest -> Bool
$c/= :: SocksRequest -> SocksRequest -> Bool
/= :: SocksRequest -> SocksRequest -> Bool
Eq, Int -> SocksRequest -> ShowS
[SocksRequest] -> ShowS
SocksRequest -> String
(Int -> SocksRequest -> ShowS)
-> (SocksRequest -> String)
-> ([SocksRequest] -> ShowS)
-> Show SocksRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksRequest -> ShowS
showsPrec :: Int -> SocksRequest -> ShowS
$cshow :: SocksRequest -> String
show :: SocksRequest -> String
$cshowList :: [SocksRequest] -> ShowS
showList :: [SocksRequest] -> ShowS
Show)

-- | Type representing SOCKS responses.

data SocksResponse = SocksResponse
    { SocksResponse -> SocksReply
responseReply    :: SocksReply
    , SocksResponse -> SocksHostAddress
responseBindAddr :: SocksHostAddress
    , SocksResponse -> PortNumber
responseBindPort :: PortNumber
    }
    deriving (SocksResponse -> SocksResponse -> Bool
(SocksResponse -> SocksResponse -> Bool)
-> (SocksResponse -> SocksResponse -> Bool) -> Eq SocksResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksResponse -> SocksResponse -> Bool
== :: SocksResponse -> SocksResponse -> Bool
$c/= :: SocksResponse -> SocksResponse -> Bool
/= :: SocksResponse -> SocksResponse -> Bool
Eq, Int -> SocksResponse -> ShowS
[SocksResponse] -> ShowS
SocksResponse -> String
(Int -> SocksResponse -> ShowS)
-> (SocksResponse -> String)
-> ([SocksResponse] -> ShowS)
-> Show SocksResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksResponse -> ShowS
showsPrec :: Int -> SocksResponse -> ShowS
$cshow :: SocksResponse -> String
show :: SocksResponse -> String
$cshowList :: [SocksResponse] -> ShowS
showList :: [SocksResponse] -> ShowS
Show)

getAddr :: (Eq a, Num a, Show a) => a -> Get SocksHostAddress
getAddr :: forall a. (Eq a, Num a, Show a) => a -> Get SocksHostAddress
getAddr a
1 = HostAddress -> SocksHostAddress
SocksAddrIPV4 (HostAddress -> SocksHostAddress)
-> Get HostAddress -> Get SocksHostAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get HostAddress
getWord32host
getAddr a
3 = SocksFQDN -> SocksHostAddress
SocksAddrDomainName (SocksFQDN -> SocksHostAddress)
-> Get SocksFQDN -> Get SocksHostAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int
getLength8 Get Int -> (Int -> Get SocksFQDN) -> Get SocksFQDN
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get SocksFQDN
getByteString)
getAddr a
4 = HostAddress6 -> SocksHostAddress
SocksAddrIPV6 (HostAddress6 -> SocksHostAddress)
-> Get HostAddress6 -> Get SocksHostAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (HostAddress
 -> HostAddress -> HostAddress -> HostAddress -> HostAddress6)
-> Get HostAddress
-> Get HostAddress
-> Get HostAddress
-> Get HostAddress
-> Get HostAddress6
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) Get HostAddress
getWord32host Get HostAddress
getWord32host Get HostAddress
getWord32host Get HostAddress
getWord32host
getAddr a
n = String -> Get SocksHostAddress
forall a. HasCallStack => String -> a
error (String
"cannot get unknown socket address type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n)

putAddr :: SocksHostAddress -> PutM ()
putAddr :: SocksHostAddress -> PutM ()
putAddr (SocksAddrIPV4 HostAddress
h) = Putter Word8
putWord8 Word8
1 PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter HostAddress
putWord32host HostAddress
h
putAddr (SocksAddrDomainName SocksFQDN
b) =
  Putter Word8
putWord8 Word8
3 PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> PutM ()
putLength8 (SocksFQDN -> Int
B.length SocksFQDN
b) PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter SocksFQDN
putByteString SocksFQDN
b
putAddr (SocksAddrIPV6 (HostAddress
a, HostAddress
b, HostAddress
c, HostAddress
d)) =
  Putter Word8
putWord8 Word8
4 PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter HostAddress -> [HostAddress] -> PutM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter HostAddress
putWord32host [HostAddress
a,HostAddress
b,HostAddress
c,HostAddress
d]

putEnum8 :: Enum e => e -> Put
putEnum8 :: forall e. Enum e => e -> PutM ()
putEnum8 = Putter Word8
putWord8 Putter Word8 -> (e -> Word8) -> e -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (e -> Int) -> e -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Int
forall a. Enum a => a -> Int
fromEnum

getEnum8 :: Enum e => Get e
getEnum8 :: forall e. Enum e => Get e
getEnum8 = Int -> e
forall a. Enum a => Int -> a
toEnum (Int -> e) -> (Word8 -> Int) -> Word8 -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> e) -> Get Word8 -> Get e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

putLength8 :: Int -> Put
putLength8 :: Int -> PutM ()
putLength8 = Putter Word8
putWord8 Putter Word8 -> (Int -> Word8) -> Int -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

getLength8 :: Get Int
getLength8 :: Get Int
getLength8 = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Get Word8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

getSocksRequest :: (Eq a, Num a, Show a) => a -> Get SocksRequest
getSocksRequest :: forall a. (Eq a, Num a, Show a) => a -> Get SocksRequest
getSocksRequest a
5 = do
  SocksCommand
cmd <- Get SocksCommand
forall e. Enum e => Get e
getEnum8
  Word8
_ <- Get Word8
getWord8
  SocksHostAddress
addr <- Get Word8
getWord8 Get Word8
-> (Word8 -> Get SocksHostAddress) -> Get SocksHostAddress
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get SocksHostAddress
forall a. (Eq a, Num a, Show a) => a -> Get SocksHostAddress
getAddr
  PortNumber
port <- Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber) -> Get Word16 -> Get PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
  SocksRequest -> Get SocksRequest
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (SocksRequest -> Get SocksRequest)
-> SocksRequest -> Get SocksRequest
forall a b. (a -> b) -> a -> b
$ SocksCommand -> SocksHostAddress -> PortNumber -> SocksRequest
SocksRequest SocksCommand
cmd SocksHostAddress
addr PortNumber
port
getSocksRequest a
v =
  String -> Get SocksRequest
forall a. HasCallStack => String -> a
error (String
"unsupported version of the protocol " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
v)

getSocksResponse :: (Eq a, Num a, Show a) => a -> Get SocksResponse
getSocksResponse :: forall a. (Eq a, Num a, Show a) => a -> Get SocksResponse
getSocksResponse a
5 = do
  SocksReply
reply <- Get SocksReply
forall e. Enum e => Get e
getEnum8
  Word8
_ <- Get Word8
getWord8
  SocksHostAddress
addr <- Get Word8
getWord8 Get Word8
-> (Word8 -> Get SocksHostAddress) -> Get SocksHostAddress
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get SocksHostAddress
forall a. (Eq a, Num a, Show a) => a -> Get SocksHostAddress
getAddr
  PortNumber
port <- Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber) -> Get Word16 -> Get PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
  SocksResponse -> Get SocksResponse
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (SocksResponse -> Get SocksResponse)
-> SocksResponse -> Get SocksResponse
forall a b. (a -> b) -> a -> b
$ SocksReply -> SocksHostAddress -> PortNumber -> SocksResponse
SocksResponse SocksReply
reply SocksHostAddress
addr PortNumber
port
getSocksResponse a
v =
  String -> Get SocksResponse
forall a. HasCallStack => String -> a
error (String
"unsupported version of the protocol " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
v)

instance Serialize SocksHello where
  put :: Putter SocksHello
put (SocksHello [SocksMethod]
ms) = do
    Putter Word8
putWord8 Word8
5
    Int -> PutM ()
putLength8 ([SocksMethod] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SocksMethod]
ms)
    (SocksMethod -> PutM ()) -> [SocksMethod] -> PutM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SocksMethod -> PutM ()
forall e. Enum e => e -> PutM ()
putEnum8 [SocksMethod]
ms
  get :: Get SocksHello
get = do
    Word8
v <- Get Word8
getWord8
    case Word8
v of
      Word8
5 -> [SocksMethod] -> SocksHello
SocksHello ([SocksMethod] -> SocksHello)
-> Get [SocksMethod] -> Get SocksHello
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int
getLength8 Get Int -> (Int -> Get [SocksMethod]) -> Get [SocksMethod]
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> Get SocksMethod -> Get [SocksMethod])
-> Get SocksMethod -> Int -> Get [SocksMethod]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Get SocksMethod -> Get [SocksMethod]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Get SocksMethod
forall e. Enum e => Get e
getEnum8)
      Word8
_ -> String -> Get SocksHello
forall a. HasCallStack => String -> a
error String
"unsupported sock hello version"

instance Serialize SocksHelloResponse where
  put :: Putter SocksHelloResponse
put (SocksHelloResponse SocksMethod
m) = Putter Word8
putWord8 Word8
5 PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SocksMethod -> PutM ()
forall e. Enum e => e -> PutM ()
putEnum8 SocksMethod
m
  get :: Get SocksHelloResponse
get = do
    Word8
v <- Get Word8
getWord8
    case Word8
v of
      Word8
5 -> SocksMethod -> SocksHelloResponse
SocksHelloResponse (SocksMethod -> SocksHelloResponse)
-> Get SocksMethod -> Get SocksHelloResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get SocksMethod
forall e. Enum e => Get e
getEnum8
      Word8
_ -> String -> Get SocksHelloResponse
forall a. HasCallStack => String -> a
error String
"unsupported sock hello response version"

instance Serialize SocksRequest where
  put :: Putter SocksRequest
put SocksRequest
req = do
    Putter Word8
putWord8 Word8
5
    SocksCommand -> PutM ()
forall e. Enum e => e -> PutM ()
putEnum8 (SocksCommand -> PutM ()) -> SocksCommand -> PutM ()
forall a b. (a -> b) -> a -> b
$ SocksRequest -> SocksCommand
requestCommand SocksRequest
req
    Putter Word8
putWord8 Word8
0
    SocksHostAddress -> PutM ()
putAddr (SocksHostAddress -> PutM ()) -> SocksHostAddress -> PutM ()
forall a b. (a -> b) -> a -> b
$ SocksRequest -> SocksHostAddress
requestDstAddr SocksRequest
req
    Putter Word16
putWord16be Putter Word16 -> Putter Word16
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PortNumber -> Word16) -> PortNumber -> Word16
forall a b. (a -> b) -> a -> b
$ SocksRequest -> PortNumber
requestDstPort SocksRequest
req

  get :: Get SocksRequest
get = Get Word8
getWord8 Get Word8 -> (Word8 -> Get SocksRequest) -> Get SocksRequest
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get SocksRequest
forall a. (Eq a, Num a, Show a) => a -> Get SocksRequest
getSocksRequest

instance Serialize SocksResponse where
  put :: Putter SocksResponse
put SocksResponse
req = do
    Putter Word8
putWord8 Word8
5
    SocksReply -> PutM ()
forall e. Enum e => e -> PutM ()
putEnum8 (SocksReply -> PutM ()) -> SocksReply -> PutM ()
forall a b. (a -> b) -> a -> b
$ SocksResponse -> SocksReply
responseReply SocksResponse
req
    Putter Word8
putWord8 Word8
0
    SocksHostAddress -> PutM ()
putAddr (SocksHostAddress -> PutM ()) -> SocksHostAddress -> PutM ()
forall a b. (a -> b) -> a -> b
$ SocksResponse -> SocksHostAddress
responseBindAddr SocksResponse
req
    Putter Word16
putWord16be Putter Word16 -> Putter Word16
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PortNumber -> Word16) -> PortNumber -> Word16
forall a b. (a -> b) -> a -> b
$ SocksResponse -> PortNumber
responseBindPort SocksResponse
req
  get :: Get SocksResponse
get = Get Word8
getWord8 Get Word8 -> (Word8 -> Get SocksResponse) -> Get SocksResponse
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get SocksResponse
forall a. (Eq a, Num a, Show a) => a -> Get SocksResponse
getSocksResponse