From a2eac5a595363bb6abeb401dbbd4cc585203c288 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Er=C3=A8be?= <romain.gerard@erebe.eu>
Date: Mon, 20 Jun 2016 17:10:48 +0200
Subject: [PATCH] Maj sock5 proxy

---
 src/socks5.hs  | 68 ++++++++++++++++++++++++++++++++++++++++++++++----
 wstunnel.cabal | 31 ++++++++++++-----------
 2 files changed, 80 insertions(+), 19 deletions(-)

diff --git a/src/socks5.hs b/src/socks5.hs
index a0873f3..c22338e 100644
--- a/src/socks5.hs
+++ b/src/socks5.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -11,7 +12,14 @@ module Socks5 where
 import           ClassyPrelude
 import           Data.Binary
 import           Data.Binary.Get
-import           Network.Socket  (HostName, PortNumber)
+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        (HostName, PortNumber)
+import           Numeric               (showHex)
 
 data AuthMethod = NoAuth
                 | GSSAPI
@@ -47,19 +55,19 @@ instance Binary RequestAuth where
   put RequestAuth{..} = do
     putWord8 (fromIntegral version)
     putWord8 (fromIntegral $ length methods)
-    sequence_ ( put <$> methods)
+    sequence_ (put <$> methods)
+    -- Check length <= 255
 
   get = do
     version <- fromIntegral <$> getWord8
     guard (version == 0x05)
     nbMethods <- fromIntegral <$> getWord8
-    guard (version <= 0xFF)
+    guard (nbMethods > 0 && nbMethods <= 0xFF)
     methods <- replicateM nbMethods get
     return $ RequestAuth version methods
 
 
 
-
 data Request = Request
   { version :: Int
   , command :: Command
@@ -70,9 +78,59 @@ data Request = Request
 data Command = Connect
              | Bind
              | UdpAssociate
-             deriving (Show, Eq)
+             deriving (Show, Eq, Enum, Bounded)
 
 
+instance Binary Command where
+  put = putWord8 . (+1) . fromIntegral . fromEnum
+
+  get = do
+    cmd <- (\val -> fromIntegral val - 1) <$> getWord8
+    guard $ cmd >= fromEnum (minBound :: Command) && cmd <= fromEnum (maxBound :: Command)
+
+    return .toEnum $ cmd
+
+
+instance Binary Request where
+  put Request{..} = do
+    putWord8 (fromIntegral version)
+    put command
+    putWord8 0x00 -- RESERVED
+    putWord8 0x03 -- DOMAINNAME
+    let host = BC8.pack addr
+    putWord8 (fromIntegral . length $ host)
+    traverse_ put host
+    putWord16be (fromIntegral port)
+
+
+
+  get = do
+    version <- fromIntegral <$> getWord8
+    guard (version == 5)
+    cmd <- get :: Get Command
+    _ <- getWord8 -- RESERVED
+
+    opCode <- fromIntegral <$> getWord8 -- DOMAINNAME
+    guard (opCode == 0x03)
+
+    length <- fromIntegral <$> getWord8
+    host <- either (const T.empty) id . E.decodeUtf8' <$> replicateM length getWord8
+    guard (not $ null host)
+
+    port <- fromIntegral <$> getWord16be
+
+    return Request
+      { version = version
+      , command = cmd
+      , addr = unpack host
+      , port = port
+      }
+
+
+
+toHex :: LByteString -> String
+toHex = foldr showHex "" . unpack
+
 data Response = Response
   { version    :: Int
   , returnCode :: RetCode
diff --git a/wstunnel.cabal b/wstunnel.cabal
index 2b76a74..000edad 100644
--- a/wstunnel.cabal
+++ b/wstunnel.cabal
@@ -16,20 +16,21 @@ cabal-version:       >=1.10
 library
   hs-source-dirs:      src
   exposed-modules:     Tunnel, Protocols, Utils
-  build-depends:       base
-                     , classy-prelude
-                     , bytestring
-                     , async
-                     , unordered-containers
-                     , network
-                     , streaming-commons
-                     , websockets
-                     , network-conduit-tls
-                     , connection
-                     , hslogger
+  build-depends:       async
+                     , base
                      , base64-bytestring >= 1.0
                      , binary >= 0.7
+                     , bytestring
+                     , classy-prelude
+                     , connection
+                     , hslogger
                      , mtl
+                     , network
+                     , network-conduit-tls
+                     , streaming-commons
+                     , text >= 1.2.2.1
+                     , unordered-containers
+                     , websockets
 
   default-language:    Haskell2010
 
@@ -38,11 +39,12 @@ executable wstunnel
   main-is:             Main.hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
-                     , wstunnel
-                     , cmdargs
-                     , classy-prelude
                      , bytestring
+                     , classy-prelude
+                     , cmdargs
                      , hslogger
+                     , text >= 1.2.2.1
+                     , wstunnel
 
   default-language:    Haskell2010
 
@@ -51,6 +53,7 @@ test-suite wstunnel-test
   hs-source-dirs:      test
   main-is:             Spec.hs
   build-depends:       base
+                     , text >= 1.2.2.1
                      , wstunnel
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010