{-# 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
_ {- Reserverd -} -> 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)
    -- Check length <= 255

  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 -- RESERVED
    Word8 -> Put
putWord8 Word8
0x03 -- DOMAINNAME
    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 -- RESERVED

    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 -- Addr type, we support only ipv4 and domainame
    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) -- DOMAINNAME OR IPV4

    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 -- Reserved
    Word8 -> Put
putWord8 Word8
0x03 -- DOMAINNAME
    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 -- RESERVED
    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 -- Type
    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
  -- , onAuthentification :: (MonadIO m, MonadError IOException m) => RequestAuth -> m ResponseAuth
  -- , onRequest          :: (MonadIO m, MonadError IOException m) => Request -> m Response
  } 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)







  --