From 5eb27ee3fb31c44fa507a0b5b6a85d1342762c94 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Er=C3=A8be?= <romain.gerard@erebe.eu>
Date: Wed, 22 Jun 2016 23:22:23 +0200
Subject: [PATCH] Maj sock5 server

---
 src/socks5.hs | 99 ++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 91 insertions(+), 8 deletions(-)

diff --git a/src/socks5.hs b/src/socks5.hs
index c22338e..74bb95c 100644
--- a/src/socks5.hs
+++ b/src/socks5.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StrictData            #-}
@@ -13,13 +15,20 @@ 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 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)
+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 = 0x05
 
 data AuthMethod = NoAuth
                 | GSSAPI
@@ -33,6 +42,17 @@ data RequestAuth = RequestAuth
   , methods :: Vector AuthMethod
   } deriving (Show, Read)
 
+data ResponseAuth = ResponseAuth
+  { version :: Int
+  , method  :: AuthMethod
+  } deriving (Show, Read)
+
+instance Binary ResponseAuth where
+  put ResponseAuth{..} = putWord8 (fromIntegral version) >> put method
+  get = ResponseAuth <$> (fromIntegral <$> getWord8)
+                     <*> get
+
+
 instance Binary AuthMethod where
   put val = case val of
     NoAuth -> putWord8 0x00
@@ -134,7 +154,7 @@ toHex = foldr showHex "" . unpack
 data Response = Response
   { version    :: Int
   , returnCode :: RetCode
-  , serverAddr :: HostName
+  , serverAddr :: HostAddress
   , serverPort :: PortNumber
   } deriving (Show)
 
@@ -147,4 +167,67 @@ data RetCode = SUCCEEDED
              | TTL_EXPIRED
              | UNSUPPORTED_COMMAND
              | UNSUPPORTED_ADDRESS_TYPE
-             deriving (Show, Eq)
+             | UNASSIGNED
+             deriving (Show, Eq, Enum, Bounded)
+
+instance Binary RetCode where
+  put = putWord8 . fromIntegral . fromEnum
+  get = toEnum . min maxBound . fromIntegral <$> getWord8
+
+
+instance Binary Response where
+  put Response{..} = do
+    putWord8 socksVersion
+    put returnCode
+    putWord8 0x00 -- Reserved
+    putWord8 0x03 -- DOMAINNAME
+    putWord32be serverAddr
+    putWord16be $ fromIntegral serverPort
+
+
+  get = do
+    version <- fromIntegral <$> getWord8
+    guard(version == fromIntegral socksVersion)
+    ret <- toEnum . min maxBound . fromIntegral <$> getWord8
+    getWord8 -- RESERVED
+    opCode <- fromIntegral <$> getWord8 -- Type
+    guard(opCode == 0x03)
+    addr <- getWord32be
+    port <- getWord16be
+
+    return Response
+      { version = version
+      , returnCode = ret
+      , serverAddr = addr
+      , serverPort = fromIntegral port
+      }
+
+
+
+data ServerSettings m = ServerSettings
+  { listenOn           :: PortNumber
+  , bindOn             :: HostName
+  , onAuthentification :: (MonadIO m, MonadError IOException m) => RequestAuth -> m ResponseAuth
+  , onRequest          :: (MonadIO m, MonadError IOException m) => Request -> m Response
+  }
+
+
+runSocks5Server :: IO ()
+runSocks5Server = do
+
+  N.runTCPServer (N.serverSettingsTCP 8888 (fromString"127.0.0.1" )) $ \cnx -> do
+    request <- decode .fromStrict <$> N.appRead cnx :: IO RequestAuth
+    traceShowM request
+    N.appWrite cnx (toStrict . encode $ ResponseAuth (fromIntegral socksVersion) NoAuth)
+    request <- decode .fromStrict <$> N.appRead cnx :: IO Request
+    traceShowM request
+
+    return ()
+
+  return ()
+
+
+
+
+
+  --