{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
module Socks5 where
import ClassyPrelude
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString as BC
import qualified Data.ByteString.Char8 as BC8
import Data.Either
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Network.Socket (HostAddress, HostName, PortNumber)
import Numeric (showHex)
import Control.Monad.Except (MonadError)
import qualified Data.Streaming.Network as N
socksVersion :: Word8
socksVersion :: Word8
socksVersion = Word8
0x05
data AuthMethod = NoAuth
| GSSAPI
| Login
| Reserved
| NotAllowed
deriving (Int -> AuthMethod -> ShowS
[AuthMethod] -> ShowS
AuthMethod -> String
(Int -> AuthMethod -> ShowS)
-> (AuthMethod -> String)
-> ([AuthMethod] -> ShowS)
-> Show AuthMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthMethod] -> ShowS
$cshowList :: [AuthMethod] -> ShowS
show :: AuthMethod -> String
$cshow :: AuthMethod -> String
showsPrec :: Int -> AuthMethod -> ShowS
$cshowsPrec :: Int -> AuthMethod -> ShowS
Show, ReadPrec [AuthMethod]
ReadPrec AuthMethod
Int -> ReadS AuthMethod
ReadS [AuthMethod]
(Int -> ReadS AuthMethod)
-> ReadS [AuthMethod]
-> ReadPrec AuthMethod
-> ReadPrec [AuthMethod]
-> Read AuthMethod
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AuthMethod]
$creadListPrec :: ReadPrec [AuthMethod]
readPrec :: ReadPrec AuthMethod
$creadPrec :: ReadPrec AuthMethod
readList :: ReadS [AuthMethod]
$creadList :: ReadS [AuthMethod]
readsPrec :: Int -> ReadS AuthMethod
$creadsPrec :: Int -> ReadS AuthMethod
Read)
data RequestAuth = RequestAuth
{ RequestAuth -> Int
version :: Int
, RequestAuth -> Vector AuthMethod
methods :: Vector AuthMethod
} deriving (Int -> RequestAuth -> ShowS
[RequestAuth] -> ShowS
RequestAuth -> String
(Int -> RequestAuth -> ShowS)
-> (RequestAuth -> String)
-> ([RequestAuth] -> ShowS)
-> Show RequestAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestAuth] -> ShowS
$cshowList :: [RequestAuth] -> ShowS
show :: RequestAuth -> String
$cshow :: RequestAuth -> String
showsPrec :: Int -> RequestAuth -> ShowS
$cshowsPrec :: Int -> RequestAuth -> ShowS
Show, ReadPrec [RequestAuth]
ReadPrec RequestAuth
Int -> ReadS RequestAuth
ReadS [RequestAuth]
(Int -> ReadS RequestAuth)
-> ReadS [RequestAuth]
-> ReadPrec RequestAuth
-> ReadPrec [RequestAuth]
-> Read RequestAuth
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RequestAuth]
$creadListPrec :: ReadPrec [RequestAuth]
readPrec :: ReadPrec RequestAuth
$creadPrec :: ReadPrec RequestAuth
readList :: ReadS [RequestAuth]
$creadList :: ReadS [RequestAuth]
readsPrec :: Int -> ReadS RequestAuth
$creadsPrec :: Int -> ReadS RequestAuth
Read)
data ResponseAuth = ResponseAuth
{ ResponseAuth -> Int
version :: Int
, ResponseAuth -> AuthMethod
method :: AuthMethod
} deriving (Int -> ResponseAuth -> ShowS
[ResponseAuth] -> ShowS
ResponseAuth -> String
(Int -> ResponseAuth -> ShowS)
-> (ResponseAuth -> String)
-> ([ResponseAuth] -> ShowS)
-> Show ResponseAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseAuth] -> ShowS
$cshowList :: [ResponseAuth] -> ShowS
show :: ResponseAuth -> String
$cshow :: ResponseAuth -> String
showsPrec :: Int -> ResponseAuth -> ShowS
$cshowsPrec :: Int -> ResponseAuth -> ShowS
Show, ReadPrec [ResponseAuth]
ReadPrec ResponseAuth
Int -> ReadS ResponseAuth
ReadS [ResponseAuth]
(Int -> ReadS ResponseAuth)
-> ReadS [ResponseAuth]
-> ReadPrec ResponseAuth
-> ReadPrec [ResponseAuth]
-> Read ResponseAuth
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ResponseAuth]
$creadListPrec :: ReadPrec [ResponseAuth]
readPrec :: ReadPrec ResponseAuth
$creadPrec :: ReadPrec ResponseAuth
readList :: ReadS [ResponseAuth]
$creadList :: ReadS [ResponseAuth]
readsPrec :: Int -> ReadS ResponseAuth
$creadsPrec :: Int -> ReadS ResponseAuth
Read)
instance Binary ResponseAuth where
put :: ResponseAuth -> Put
put ResponseAuth{Int
AuthMethod
method :: AuthMethod
version :: Int
$sel:method:ResponseAuth :: ResponseAuth -> AuthMethod
$sel:version:ResponseAuth :: ResponseAuth -> Int
..} = Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
version) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AuthMethod -> Put
forall t. Binary t => t -> Put
put AuthMethod
method
get :: Get ResponseAuth
get = Int -> AuthMethod -> ResponseAuth
ResponseAuth (Int -> AuthMethod -> ResponseAuth)
-> Get Int -> Get (AuthMethod -> ResponseAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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)
Get (AuthMethod -> ResponseAuth)
-> Get AuthMethod -> Get ResponseAuth
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get AuthMethod
forall t. Binary t => Get t
get
instance Binary AuthMethod where
put :: AuthMethod -> Put
put AuthMethod
val = case AuthMethod
val of
AuthMethod
NoAuth -> Word8 -> Put
putWord8 Word8
0x00
AuthMethod
GSSAPI -> Word8 -> Put
putWord8 Word8
0x01
AuthMethod
Login -> Word8 -> Put
putWord8 Word8
0x02
AuthMethod
NotAllowed -> Word8 -> Put
putWord8 Word8
0xFF
AuthMethod
_ -> Word8 -> Put
putWord8 Word8
0x03
get :: Get AuthMethod
get = do
Word8
method <- Get Word8
getWord8
AuthMethod -> Get AuthMethod
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthMethod -> Get AuthMethod) -> AuthMethod -> Get AuthMethod
forall a b. (a -> b) -> a -> b
$ case Word8
method of
Word8
0x00 -> AuthMethod
NoAuth
Word8
0x01 -> AuthMethod
GSSAPI
Word8
0x02 -> AuthMethod
Login
Word8
0xFF -> AuthMethod
NotAllowed
Word8
_ -> AuthMethod
Reserved
instance Binary RequestAuth where
put :: RequestAuth -> Put
put RequestAuth{Int
Vector AuthMethod
methods :: Vector AuthMethod
version :: Int
$sel:methods:RequestAuth :: RequestAuth -> Vector AuthMethod
$sel:version:RequestAuth :: RequestAuth -> Int
..} = do
Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
version)
Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Vector AuthMethod -> Int
forall mono. MonoFoldable mono => mono -> Int
length Vector AuthMethod
methods)
Vector Put -> Put
forall (m :: * -> *) mono.
(Applicative m, MonoFoldable mono, Element mono ~ m ()) =>
mono -> m ()
sequence_ (AuthMethod -> Put
forall t. Binary t => t -> Put
put (AuthMethod -> Put) -> Vector AuthMethod -> Vector Put
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector AuthMethod
methods)
get :: Get RequestAuth
get = do
Int
version <- 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
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x05)
Int
nbMethods <- 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
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
nbMethods Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
nbMethods Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xFF)
Vector AuthMethod
methods <- Index (Vector AuthMethod)
-> Get (Element (Vector AuthMethod)) -> Get (Vector AuthMethod)
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
Index seq -> m (Element seq) -> m seq
replicateM Int
Index (Vector AuthMethod)
nbMethods Get (Element (Vector AuthMethod))
forall t. Binary t => Get t
get
RequestAuth -> Get RequestAuth
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestAuth -> Get RequestAuth) -> RequestAuth -> Get RequestAuth
forall a b. (a -> b) -> a -> b
$ Int -> Vector AuthMethod -> RequestAuth
RequestAuth Int
version Vector AuthMethod
methods
data Request = Request
{ Request -> Int
version :: Int
, Request -> Command
command :: Command
, Request -> String
addr :: HostName
, Request -> PortNumber
port :: PortNumber
} deriving (Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> String
$cshow :: Request -> String
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show)
data Command = Connect
| Bind
| UdpAssociate
deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Int -> Command
Command -> Int
Command -> [Command]
Command -> Command
Command -> Command -> [Command]
Command -> Command -> Command -> [Command]
(Command -> Command)
-> (Command -> Command)
-> (Int -> Command)
-> (Command -> Int)
-> (Command -> [Command])
-> (Command -> Command -> [Command])
-> (Command -> Command -> [Command])
-> (Command -> Command -> Command -> [Command])
-> Enum Command
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Command -> Command -> Command -> [Command]
$cenumFromThenTo :: Command -> Command -> Command -> [Command]
enumFromTo :: Command -> Command -> [Command]
$cenumFromTo :: Command -> Command -> [Command]
enumFromThen :: Command -> Command -> [Command]
$cenumFromThen :: Command -> Command -> [Command]
enumFrom :: Command -> [Command]
$cenumFrom :: Command -> [Command]
fromEnum :: Command -> Int
$cfromEnum :: Command -> Int
toEnum :: Int -> Command
$ctoEnum :: Int -> Command
pred :: Command -> Command
$cpred :: Command -> Command
succ :: Command -> Command
$csucc :: Command -> Command
Enum, Command
Command -> Command -> Bounded Command
forall a. a -> a -> Bounded a
maxBound :: Command
$cmaxBound :: Command
minBound :: Command
$cminBound :: Command
Bounded)
instance Binary Command where
put :: Command -> Put
put = Word8 -> Put
putWord8 (Word8 -> Put) -> (Command -> Word8) -> Command -> Put
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+Word8
1) (Word8 -> Word8) -> (Command -> Word8) -> Command -> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Command -> Int) -> Command -> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Command -> Int
forall a. Enum a => a -> Int
fromEnum
get :: Get Command
get = do
Int
cmd <- (\Word8
val -> Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
val Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Word8 -> Int) -> Get Word8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> Bool -> Get ()
forall a b. (a -> b) -> a -> b
$ Int
cmd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Command -> Int
forall a. Enum a => a -> Int
fromEnum (Command
forall a. Bounded a => a
minBound :: Command) Bool -> Bool -> Bool
&& Int
cmd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Command -> Int
forall a. Enum a => a -> Int
fromEnum (Command
forall a. Bounded a => a
maxBound :: Command)
Command -> Get Command
forall (m :: * -> *) a. Monad m => a -> m a
return (Command -> Get Command) -> (Int -> Command) -> Int -> Get Command
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.Int -> Command
forall a. Enum a => Int -> a
toEnum (Int -> Get Command) -> Int -> Get Command
forall a b. (a -> b) -> a -> b
$ Int
cmd
instance Binary Request where
put :: Request -> Put
put Request{Int
String
PortNumber
Command
port :: PortNumber
addr :: String
command :: Command
version :: Int
$sel:port:Request :: Request -> PortNumber
$sel:addr:Request :: Request -> String
$sel:command:Request :: Request -> Command
$sel:version:Request :: Request -> Int
..} = do
Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
version)
Command -> Put
forall t. Binary t => t -> Put
put Command
command
Word8 -> Put
putWord8 Word8
0x00
Word8 -> Put
putWord8 Word8
0x03
let host :: ByteString
host = String -> ByteString
BC8.pack String
addr
Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (ByteString -> Int) -> ByteString -> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Int
forall mono. MonoFoldable mono => mono -> Int
length (ByteString -> Word8) -> ByteString -> Word8
forall a b. (a -> b) -> a -> b
$ ByteString
host)
(Element ByteString -> Put) -> ByteString -> Put
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ Element ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
host
Word16 -> Put
putWord16be (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)
get :: Get Request
get = do
Int
version <- 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
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5)
Command
cmd <- Get Command
forall t. Binary t => Get t
get :: Get Command
Word8
_ <- Get Word8
getWord8
Integer
opCode <- Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Integer) -> Get Word8 -> Get Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
opCode Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0x03 Bool -> Bool -> Bool
|| Integer
opCode Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0x01)
Text
host <- if Integer
opCode Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0x03
then do
Int
length <- 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
Text
host <- (UnicodeException -> Text)
-> (Text -> Text) -> Either UnicodeException Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> UnicodeException -> Text
forall a b. a -> b -> a
const Text
T.empty) Text -> Text
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either UnicodeException Text -> Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either UnicodeException Text
E.decodeUtf8' (ByteString -> Text) -> Get ByteString -> Get Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index ByteString -> Get (Element ByteString) -> Get ByteString
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
Index seq -> m (Element seq) -> m seq
replicateM Int
Index ByteString
length Get Word8
Get (Element ByteString)
getWord8
Text -> Get Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
host
else do
[Word8]
ipv4 <- Index [Word8] -> Get (Element [Word8]) -> Get [Word8]
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
Index seq -> m (Element seq) -> m seq
replicateM Index [Word8]
4 Get Word8
Get (Element [Word8])
getWord8 :: Get [Word8]
let ipv4Str :: Text
ipv4Str = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Word8 -> Text) -> [Word8] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> (Word8 -> Int) -> Word8 -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum) [Word8]
ipv4
Text -> Get Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ipv4Str
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Text
host)
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
Request -> Get Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request :: Int -> Command -> String -> PortNumber -> Request
Request
{ $sel:version:Request :: Int
version = Int
version
, $sel:command:Request :: Command
command = Command
cmd
, $sel:addr:Request :: String
addr = Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
host
, $sel:port:Request :: PortNumber
port = PortNumber
port
}
toHex :: LByteString -> String
toHex :: LByteString -> String
toHex = (Element [Word8] -> ShowS) -> String -> [Word8] -> String
forall mono b.
MonoFoldable mono =>
(Element mono -> b -> b) -> b -> mono -> b
foldr Element [Word8] -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex String
"" ([Word8] -> String)
-> (LByteString -> [Word8]) -> LByteString -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LByteString -> [Word8]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack
data Response = Response
{ Response -> Int
version :: Int
, Response -> RetCode
returnCode :: RetCode
, Response -> String
serverAddr :: HostName
, Response -> PortNumber
serverPort :: PortNumber
} deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)
data RetCode = SUCCEEDED
| GENERAL_FAILURE
| NOT_ALLOWED
| NO_NETWORK
| HOST_UNREACHABLE
| CONNECTION_REFUSED
| TTL_EXPIRED
| UNSUPPORTED_COMMAND
| UNSUPPORTED_ADDRESS_TYPE
| UNASSIGNED
deriving (Int -> RetCode -> ShowS
[RetCode] -> ShowS
RetCode -> String
(Int -> RetCode -> ShowS)
-> (RetCode -> String) -> ([RetCode] -> ShowS) -> Show RetCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RetCode] -> ShowS
$cshowList :: [RetCode] -> ShowS
show :: RetCode -> String
$cshow :: RetCode -> String
showsPrec :: Int -> RetCode -> ShowS
$cshowsPrec :: Int -> RetCode -> ShowS
Show, RetCode -> RetCode -> Bool
(RetCode -> RetCode -> Bool)
-> (RetCode -> RetCode -> Bool) -> Eq RetCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RetCode -> RetCode -> Bool
$c/= :: RetCode -> RetCode -> Bool
== :: RetCode -> RetCode -> Bool
$c== :: RetCode -> RetCode -> Bool
Eq, Int -> RetCode
RetCode -> Int
RetCode -> [RetCode]
RetCode -> RetCode
RetCode -> RetCode -> [RetCode]
RetCode -> RetCode -> RetCode -> [RetCode]
(RetCode -> RetCode)
-> (RetCode -> RetCode)
-> (Int -> RetCode)
-> (RetCode -> Int)
-> (RetCode -> [RetCode])
-> (RetCode -> RetCode -> [RetCode])
-> (RetCode -> RetCode -> [RetCode])
-> (RetCode -> RetCode -> RetCode -> [RetCode])
-> Enum RetCode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: RetCode -> RetCode -> RetCode -> [RetCode]
$cenumFromThenTo :: RetCode -> RetCode -> RetCode -> [RetCode]
enumFromTo :: RetCode -> RetCode -> [RetCode]
$cenumFromTo :: RetCode -> RetCode -> [RetCode]
enumFromThen :: RetCode -> RetCode -> [RetCode]
$cenumFromThen :: RetCode -> RetCode -> [RetCode]
enumFrom :: RetCode -> [RetCode]
$cenumFrom :: RetCode -> [RetCode]
fromEnum :: RetCode -> Int
$cfromEnum :: RetCode -> Int
toEnum :: Int -> RetCode
$ctoEnum :: Int -> RetCode
pred :: RetCode -> RetCode
$cpred :: RetCode -> RetCode
succ :: RetCode -> RetCode
$csucc :: RetCode -> RetCode
Enum, RetCode
RetCode -> RetCode -> Bounded RetCode
forall a. a -> a -> Bounded a
maxBound :: RetCode
$cmaxBound :: RetCode
minBound :: RetCode
$cminBound :: RetCode
Bounded)
instance Binary RetCode where
put :: RetCode -> Put
put = Word8 -> Put
putWord8 (Word8 -> Put) -> (RetCode -> Word8) -> RetCode -> Put
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (RetCode -> Int) -> RetCode -> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RetCode -> Int
forall a. Enum a => a -> Int
fromEnum
get :: Get RetCode
get = Int -> RetCode
forall a. Enum a => Int -> a
toEnum (Int -> RetCode) -> (Word8 -> Int) -> Word8 -> RetCode
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
forall a. Bounded a => a
maxBound (Int -> Int) -> (Word8 -> Int) -> Word8 -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> RetCode) -> Get Word8 -> Get RetCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
instance Binary Response where
put :: Response -> Put
put Response{Int
String
PortNumber
RetCode
serverPort :: PortNumber
serverAddr :: String
returnCode :: RetCode
version :: Int
$sel:serverPort:Response :: Response -> PortNumber
$sel:serverAddr:Response :: Response -> String
$sel:returnCode:Response :: Response -> RetCode
$sel:version:Response :: Response -> Int
..} = do
Word8 -> Put
putWord8 Word8
socksVersion
RetCode -> Put
forall t. Binary t => t -> Put
put RetCode
returnCode
Word8 -> Put
putWord8 Word8
0x00
Word8 -> Put
putWord8 Word8
0x03
let host :: ByteString
host = String -> ByteString
BC8.pack String
serverAddr
Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (ByteString -> Int) -> ByteString -> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Int
forall mono. MonoFoldable mono => mono -> Int
length (ByteString -> Word8) -> ByteString -> Word8
forall a b. (a -> b) -> a -> b
$ ByteString
host)
(Element ByteString -> Put) -> ByteString -> Put
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ Element ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
host
Word16 -> Put
putWord16be (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
serverPort)
get :: Get Response
get = do
Int
version <- 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
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard(Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
socksVersion)
RetCode
ret <- Int -> RetCode
forall a. Enum a => Int -> a
toEnum (Int -> RetCode) -> (Word8 -> Int) -> Word8 -> RetCode
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
forall a. Bounded a => a
maxBound (Int -> Int) -> (Word8 -> Int) -> Word8 -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> RetCode) -> Get Word8 -> Get RetCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
Get Word8
getWord8
Integer
opCode <- Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Integer) -> Get Word8 -> Get Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard(Integer
opCode Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0x03)
Int
length <- 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
Text
host <- (UnicodeException -> Text)
-> (Text -> Text) -> Either UnicodeException Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> UnicodeException -> Text
forall a b. a -> b -> a
const Text
T.empty) Text -> Text
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either UnicodeException Text -> Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either UnicodeException Text
E.decodeUtf8' (ByteString -> Text) -> Get ByteString -> Get Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index ByteString -> Get (Element ByteString) -> Get ByteString
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
Index seq -> m (Element seq) -> m seq
replicateM Int
Index ByteString
length Get Word8
Get (Element ByteString)
getWord8
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Text
host)
Word16
port <- Get Word16
getWord16be
Response -> Get Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response :: Int -> RetCode -> String -> PortNumber -> Response
Response
{ $sel:version:Response :: Int
version = Int
version
, $sel:returnCode:Response :: RetCode
returnCode = RetCode
ret
, $sel:serverAddr:Response :: String
serverAddr = Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
host
, $sel:serverPort:Response :: PortNumber
serverPort = Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port
}
data ServerSettings = ServerSettings
{ ServerSettings -> PortNumber
listenOn :: PortNumber
, ServerSettings -> String
bindOn :: HostName
} deriving (Int -> ServerSettings -> ShowS
[ServerSettings] -> ShowS
ServerSettings -> String
(Int -> ServerSettings -> ShowS)
-> (ServerSettings -> String)
-> ([ServerSettings] -> ShowS)
-> Show ServerSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerSettings] -> ShowS
$cshowList :: [ServerSettings] -> ShowS
show :: ServerSettings -> String
$cshow :: ServerSettings -> String
showsPrec :: Int -> ServerSettings -> ShowS
$cshowsPrec :: Int -> ServerSettings -> ShowS
Show)